subsection\<open>The reduction from \<open>3CNF-SAT\<close> To \<open>Set Cover\<close> is polynomial\<close>

theory TSTSC_Poly
  imports Polynomial_Reductions Three_Sat_To_Set_Cover
begin

definition "size_IS = (\<lambda>(E,k). card E)"
definition "size_VC = (\<lambda>(E,k). card E)"

subsubsection \<open>\<open>Independent Set\<close> To \<open>Vertex Cover\<close>\<close>

paragraph \<open>A trivial implementation\<close>

text \<open>Here we assume that we have an operation that returns
      the size of the set of vertices.\<close>

definition "mop_get_vertices E = REST [ (\<Union> E)  \<mapsto> 2 * card E + 1]"

definition "mop_get_vertices_card E = REST [(card (\<Union> E)) \<mapsto> 2 * card E + 2]"

text \<open>Then we can easily give an abstract algorithm for the reduction:\<close>

definition "is_to_vc = (\<lambda>(E,k).
          do {
            s \<leftarrow> mop_get_vertices_card E;
            if k > s  then
              RETURNT (E,k)
            else
              RETURNT (E, s-k)
          })"

definition "vc_time n = 2 * n + 2"
definition "vc_space n = n"

lemma is_to_vc_refines:
  "is_to_vc vc \<le> SPEC (\<lambda>y. y = is_vc vc) (\<lambda>_. vc_time (size_IS vc))"
  unfolding is_to_vc_def is_vc_def SPEC_def mop_get_vertices_card_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close>)
  by (auto simp: size_IS_def size_VC_def vc_time_def vc_space_def)

lemma is_to_vc_size:
  "size_VC (is_vc a) \<le> vc_space (size_IS a)"
  apply(cases a)
  by (auto simp: is_vc_def size_IS_def size_VC_def vc_time_def vc_space_def)

thm is_reduction_is_vc

text \<open>And we show that it actually is a polynomial reduction:\<close>

theorem is_to_vc_ispolyred: "ispolyred is_to_vc independent_set vertex_cover size_IS size_VC"
  unfolding ispolyred_def
  apply(rule exI[where x=is_vc])
  apply(rule exI[where x=vc_time])
  apply(rule exI[where x=vc_space])
  apply(safe)
  subgoal using is_to_vc_refines by blast
  subgoal using is_to_vc_size  by blast
  subgoal unfolding poly_def vc_time_def apply(rule exI[where x=1]) by auto
  subgoal unfolding poly_def vc_space_def apply(rule exI[where x=1]) by simp
  subgoal using is_reduction_is_vc .
  done

paragraph \<open>A more fine grained algorith\<close>

text \<open>now we assume to only have more fine grained basic operations.\<close>

text \<open>This setup is actually unrealistic, it is hard to imagine a datastructure with
  constant insertion and constant cardinality query.
     TODO: make cost of insert linear in size of S\<close>

definition "mop_set_insert S s = REST [insert s S \<mapsto> 1]"

definition "mop_set_card S  = REST [card S \<mapsto> 1]"

definition "mop_set_empty_set = REST [ {} \<mapsto> 1]"

text \<open>Now we want to work on lists of tuples to represent the Edge set:\<close>

definition "R_edge_set_tuple_list = {(xs,E) |xs E. ((\<lambda>(a,b). {a,b}) ` (set xs) = E \<and> distinct xs
           \<and> inj_on (\<lambda>(a,b). {a,b}) (set xs)  )}"
text \<open>here the constraint @{term inj_on} means, that the edge list xs
       does not contain any loops ( (a,a) ),
        or both symmetric edges ( (a,b)\<in>set xs \<and> (b,a)\<in>set xs )\<close>

text \<open>we can restate the specification to get the cardinality of the set of vertices given
      an edge list, and that it refines the operation @{term mop_get_vertices_card}\<close>

definition "mop_get_vertices_card' xs = REST [(card (\<Union> ((\<lambda>(a,b). {a,b}) ` (set xs)))) \<mapsto> 2 * length xs + 2]"

lemma mop_get_vertices_card_data_refine:
  assumes "(xs,E)\<in>R_edge_set_tuple_list"
  shows "mop_get_vertices_card' xs \<le> mop_get_vertices_card E"
proof -
  from assms have E: "E = (\<lambda>(a,b). {a,b}) ` (set xs)"
     and *: "distinct xs""inj_on (\<lambda>(a,b). {a,b}) (set xs)"
    unfolding R_edge_set_tuple_list_def by auto
  have **: "card E = length xs"
    by(simp add: card_image distinct_card E *)
  show ?thesis
    unfolding mop_get_vertices_card'_def mop_get_vertices_card_def
    unfolding ** by(simp add: E)
qed

text \<open>now let's implement getting the cardinality of V with the basic set operations\<close>

definition "mop_get_vertices' es = SPECT [\<Union> ((\<lambda>(a,b). {a,b}) ` (set es)) \<mapsto> 2 * length es + 1]"

definition get_vertices where
  "get_vertices es =
    do { S \<leftarrow> mop_set_empty_set;
      S' \<leftarrow> nfoldli es (\<lambda>_. True)
            (\<lambda>(a,b) S. do {
                  S \<leftarrow> mop_set_insert S a;
                  S \<leftarrow> mop_set_insert S b;
                  RETURNT S })

        S;
      RETURNT S'
  }"

lemma get_vertices_refine:
  "get_vertices xs \<le> mop_get_vertices' xs"
proof -
  let ?I = "\<lambda>(xs::('b*'b)list) ys (S::'b set).  S = \<Union> ((\<lambda>(a,b). {a,b}) ` (set xs))"

  show ?thesis
  unfolding get_vertices_def mop_get_vertices'_def
  apply(rule T_specifies_I)
  apply(subst nfoldliIE_def[symmetric, where I="?I" and E=2])
  unfolding mop_set_empty_set_def
  apply(vcg' -)
  apply(rule nfoldliIE_rule[THEN T_specifies_rev, THEN T_conseq4, where P2="?I xs []" ])
       apply simp
  subgoal
    apply(rule T_specifies_I)
    unfolding mop_set_insert_def
    apply(vcg' -)
    apply auto unfolding Some_le_emb'_conv
    by auto
     apply simp
    apply simp
  apply (rule order.refl)
  unfolding mop_set_card_def
  apply (vcg' -) apply auto unfolding Some_le_emb'_conv Some_eq_emb'_conv
   apply (auto simp add: one_enat_def)
  done
qed

definition get_vertices_card :: "('b*'b) list \<Rightarrow> nat nrest" where
  "get_vertices_card es = do {
      V \<leftarrow> get_vertices es;
      n \<leftarrow> mop_set_card V;
      RETURNT n
    }"

thm get_vertices_refine[unfolded mop_get_vertices'_def,
                THEN T_specifies_rev, THEN T_conseq4]

lemma get_vertices_card_refine:
  "get_vertices_card xs \<le> mop_get_vertices_card' xs"
  unfolding get_vertices_card_def mop_get_vertices_card'_def
  apply(rule T_specifies_I)
  apply(vcg' - rules: get_vertices_refine[unfolded mop_get_vertices'_def,
                THEN T_specifies_rev, THEN T_conseq4])
  unfolding mop_set_card_def
  apply (vcg' -) unfolding Some_le_emb'_conv Some_eq_emb'_conv
  by (auto simp add: one_enat_def split: if_splits)

lemma get_vertices_card_data_refine:
  assumes "(xs,E)\<in>R_edge_set_tuple_list"
  shows "get_vertices_card xs \<le>  (mop_get_vertices_card E)"
  apply(rule order.trans)
  apply(rule   get_vertices_card_refine)
  apply(rule mop_get_vertices_card_data_refine)
  by fact

text \<open>now we can give a refined algorithm, only using the fine grained operations:\<close>

definition "is_to_vc2 = (\<lambda>(xs,k).
          do {
            s \<leftarrow> get_vertices_card xs;
            if k > s  then
              RETURNT (xs,k)
            else
              RETURNT (xs, s-k)
          })"

lemma R_reintro: "A \<le>   B \<Longrightarrow> A \<le> \<Down>Id B" by simp

term " prod_rel R_edge_set_tuple_list Id"
lemma is_to_vc2_refines:
  "((xs,k),(E,k)) \<in> R_edge_set_tuple_list \<times>\<^sub>r Id
     \<Longrightarrow> is_to_vc2 (xs,k) \<le> \<Down> (R_edge_set_tuple_list \<times>\<^sub>r Id) (is_to_vc (E,k))"
  unfolding is_to_vc_def is_to_vc2_def
  apply (refine_rcg get_vertices_card_data_refine[THEN R_reintro] )
  subgoal by (auto simp: prod_rel_def_internal)
  subgoal by (auto simp: prod_rel_def_internal)
  subgoal by (auto simp: RETURNT_refine prod_rel_def_internal)
  subgoal by(auto intro!: RETURNT_refine simp: prod_rel_def_internal)
  done
lemma is_to_vc2_refines':
  "(i',i) \<in> R_edge_set_tuple_list \<times>\<^sub>r Id
     \<Longrightarrow> is_to_vc2 i' \<le> \<Down> (R_edge_set_tuple_list \<times>\<^sub>r Id) (is_to_vc i)"
  unfolding is_to_vc_def is_to_vc2_def
  apply (refine_rcg get_vertices_card_data_refine[THEN R_reintro] )
  subgoal by (auto simp: prod_rel_def_internal)
  subgoal by (auto simp: prod_rel_def_internal)
  subgoal by (auto simp: RETURNT_refine prod_rel_def_internal)
  subgoal by(auto intro!: RETURNT_refine simp: prod_rel_def_internal)
  done

thm ispolyredd_refine[OF is_to_vc_ispolyred[THEN ispolyredd_generalizes_ispolyredD] is_to_vc2_refines' ]
    is_to_vc2_refines

text \<open>Finally we can show that the new algorithm also is a polynomial reduction acting on
      lists of tuples instead of an abstract edge set\<close>

theorem "ispolyredd is_to_vc2
       (R_edge_set_tuple_list \<times>\<^sub>r nat_rel) (R_edge_set_tuple_list \<times>\<^sub>r nat_rel)
        independent_set vertex_cover size_IS size_VC"
  apply(rule ispolyredd_refine[OF is_to_vc_ispolyred[THEN ispolyredd_generalizes_ispolyredD], simplified])
  apply(rule is_to_vc2_refines' ) .

subsubsection \<open>\<open>Vertex Cover\<close> To \<open>Set Cover\<close>\<close>

definition "mop_set_to_list V = SPEC (\<lambda>xs. set xs = V \<and> distinct xs) (\<lambda>_. 1)"

definition "mop_set_member S s = SPECT [ s \<in> S \<mapsto> 1] "

definition "mop_check_ugraph E = SPECT [ugraph E \<mapsto> 1]"

definition "innerset = (\<lambda>v es.
 do {
  Rv \<leftarrow> mop_set_empty_set;
  Rv \<leftarrow> nfoldli es (\<lambda>_. True)
          (\<lambda>e Rv. do {
                    b \<leftarrow> mop_set_member e v;
                    if b then mop_set_insert Rv e
                       else RETURNT Rv})
      Rv;
  RETURNT Rv
})"

definition "innerset_spec v es = SPECT [  {e. e \<in> (set es) \<and> v \<in> e} \<mapsto> (1+1) * length es + 1 ]"

lemma innerset_refines:
  "innerset v es \<le> innerset_spec v es"
proof -
  let ?I="\<lambda>xs ys S. S = {e. e \<in> set xs \<and> v \<in> e} "

  show ?thesis
    unfolding innerset_def innerset_spec_def  mop_set_empty_set_def mop_set_member_def mop_set_insert_def
    apply(subst nfoldliIE_def[symmetric, where I="?I" and E="2"])
    apply(rule T_specifies_I)
    apply(vcg' \<open>-\<close> rules: T_SPEC )
    unfolding mop_set_empty_set_def
    apply(vcg' -)
    apply(rule nfoldliIE_rule[THEN T_specifies_rev, THEN T_conseq4, where P2="?I es []" ])
    subgoal apply simp done
    subgoal unfolding mop_set_insert_def
      apply(rule T_specifies_I)
      apply(vcg' \<open>-\<close> rules:  ) unfolding Some_le_emb'_conv Some_eq_emb'_conv
      by (auto simp add: one_enat_def split: if_splits)
    subgoal by auto
    subgoal by auto
     apply (rule order.refl)
    subgoal apply(vcg' -) unfolding Some_le_emb'_conv Some_eq_emb'_conv
      by (auto simp add: one_enat_def split: if_splits)
    done
qed

definition "outerset = (\<lambda>es vs.
  do {
    R \<leftarrow> mop_set_empty_set;
    R \<leftarrow> nfoldli vs (\<lambda>_. True)
       (\<lambda>v R. do {
              Rv \<leftarrow> innerset v es;
              R \<leftarrow> mop_set_insert R Rv;
               RETURNT R })
         R;
    RETURNT R
  })"

definition "outerset_spec es vs
       = SPECT [  {{e. e \<in> set es \<and> v \<in> e} | v. v \<in> set vs} \<mapsto> 1 + ( 2 + (1+1) * length es) * length vs]"

lemmas aha = innerset_refines[unfolded innerset_spec_def,
                THEN T_specifies_rev, THEN T_conseq4]

lemma outerset_refines:
  "outerset es vs \<le> outerset_spec es vs"
proof -
  let ?I="\<lambda>xs ys S. S = {{e. e \<in> set es \<and> v \<in> e} | v. v \<in> set xs} "

  show ?thesis
    unfolding outerset_def outerset_spec_def  mop_set_empty_set_def
    apply(subst nfoldliIE_def[symmetric, where I="?I" and E="2*length es + 2"])
    apply(rule T_specifies_I)
    apply(vcg' \<open>-\<close> rules: T_SPEC )
    unfolding mop_set_empty_set_def
    apply(vcg' -)
    apply(rule nfoldliIE_rule[THEN T_specifies_rev, THEN T_conseq4, where P2="?I vs []" ])
    subgoal apply simp done
    subgoal unfolding mop_set_insert_def
      apply(rule T_specifies_I)
      apply(vcg' \<open>-\<close> rules: aha) unfolding Some_le_emb'_conv Some_eq_emb'_conv
      by (auto simp add: one_enat_def split: if_splits)
    subgoal by auto
    subgoal by auto
     apply (rule order.refl)
    subgoal apply(vcg' -) unfolding Some_le_emb'_conv Some_eq_emb'_conv
      by (auto simp add: one_enat_def split: if_splits)
    done
qed

definition "vc_to_sc = (\<lambda>(E,k).
  do {
    b \<leftarrow> mop_check_ugraph E;
    V  \<leftarrow> mop_get_vertices E;
    cV \<leftarrow> mop_set_card V;
    vs \<leftarrow> mop_set_to_list V;
    if b \<and> k \<le> cV then
      do {
        es \<leftarrow> mop_set_to_list E;
        ASSERT (length vs \<le> 2 * length es);
        ASSERT (length es = card E);
        R \<leftarrow> outerset es vs;
        RETURNT ( R, k)
      }
    else RETURNT ( {{undefined}}, 0 )
  } )"

definition "sc_time n = 1+1+ (2 * n + 1) + 1 + 1 + (1 + ( 1 + (1+1) * n) * (4*n))"

lemmas aha2 = outerset_refines[unfolded outerset_spec_def,
                THEN T_specifies_rev, THEN T_conseq4]

lemma pf: "a\<le>b \<Longrightarrow> enat a \<le> enat b" by auto
lemma k: "enat a + enat b = enat (a+b)" by auto

lemma card_Un: "finite E \<Longrightarrow> card (\<Union>E) \<le> sum card E"
  by(induct  rule: finite_induct) (auto intro: order.trans[OF card_Un_le])

lemma vc_to_sc_refines:
  "vc_to_sc (E,k) \<le> SPEC (\<lambda>y. y = vc_sc (E,k)) (\<lambda>_. sc_time (size_VC (E,k)))"
  unfolding SPEC_def
  unfolding vc_to_sc_def vc_sc_def
      mop_set_to_list_def mop_get_vertices_def mop_set_card_def
      mop_check_ugraph_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC aha2)
  subgoal apply simp  apply safe
       apply(auto split: if_splits)
    subgoal premises prems apply(auto simp: sc_time_def size_VC_def)
      unfolding one_enat_def apply simp
      apply(rule add_mono)
      subgoal using prems(8,9) by auto
      subgoal using prems(8,9) apply(intro mult_mono) by auto
      done
    done
  subgoal
    by(auto simp: distinct_card)
  subgoal    for a b x xa
    unfolding ugraph_def apply auto
    subgoal premises prems
    proof -
      have "length x = card (\<Union> a)"
        apply(subst distinct_card[symmetric])
        using prems  by auto
      also have "\<dots> \<le> sum card a"
        apply(rule card_Un) using prems by simp
      also have "\<dots> = sum card (set xa)" using prems by auto
      also have "\<dots> = 2 * card (set xa)" using prems by simp
      also have "\<dots> = 2 * length xa"
        apply(subst distinct_card[symmetric])using prems by auto
      finally show ?thesis .
    qed
    done
  subgoal
    apply auto
    unfolding Some_le_emb'_conv Some_eq_emb'_conv
    by (auto simp: size_IS_def size_VC_def sc_time_def  one_enat_def)
  done

definition "size_SC = (\<lambda>(E,k). sum card E)"

definition "sc_space n = 1 + 2 * (n * n)"

lemma sum_Un: "finite E \<Longrightarrow> (\<And>e. e\<in>E \<Longrightarrow> finite e) \<Longrightarrow> (\<And>x. f x \<ge> (0::nat))
     \<Longrightarrow> sum f (\<Union>E) \<le> sum (\<lambda>x. sum f x) E"
  by (induct  rule: finite_induct)
    (simp_all add: sum_Un_nat)

lemma vc_to_sc_size:
  "size_SC (vc_sc a) \<le> sc_space (size_VC a)"
  apply(cases a)
  apply (auto simp: vc_sc_def size_SC_def size_VC_def vc_time_def sc_space_def)
  subgoal premises prems for E k
  proof -
    have *: "{{e \<in> E. v \<in> e} |v. \<exists>x\<in>E. v \<in> x} = (\<lambda>v. {e \<in> E. v \<in> e}) ` (\<Union> E)" by blast
    have "sum card {{e \<in> E. v \<in> e} |v. \<exists>x\<in>E. v \<in> x}
      = sum card ((\<lambda>v. {e \<in> E. v \<in> e}) ` (\<Union> E))" unfolding * ..
    also have "\<dots> \<le> sum (card o (\<lambda>v. {e \<in> E. v \<in> e})) (\<Union> E)"
      apply(rule sum_image_le) using prems(2) ugraph_vertex_set_finite by auto
    also have "\<dots> \<le> sum (\<lambda>x. sum (card o (\<lambda>v. {e \<in> E. v \<in> e})) x) E " apply(rule sum_Un)
      using prems unfolding ugraph_def apply auto
      by (meson finite_subset le_cSup_finite prems(2) ugraph_vertex_set_finite)
    also have "\<dots> \<le> sum (\<lambda>x. sum (\<lambda>_. card E) x) E"
      apply(rule sum_mono)
      apply(rule sum_mono) apply auto
      by (metis (no_types, lifting) card_mono mem_Collect_eq prems(2) subsetI ugraph_def)
    also have "\<dots> = sum (\<lambda>x. 2 * card E) E"
      apply(rule sum.cong) using prems(2) unfolding ugraph_def by simp_all
    also have "\<dots> = 2* (card E) * (card E)" by simp
    finally show ?thesis by simp
  qed
  done

theorem vc_to_sc_ispolyred: "ispolyred vc_to_sc vertex_cover set_cover size_VC size_SC"
  unfolding ispolyred_def
  apply(rule exI[where x=vc_sc])
  apply(rule exI[where x=sc_time])
  apply(rule exI[where x=sc_space])
  apply(safe)
  subgoal using vc_to_sc_refines by blast
  subgoal using vc_to_sc_size  by blast
  subgoal unfolding poly_def sc_time_def apply(rule exI[where x=2]) by auto
  subgoal unfolding poly_def sc_space_def apply(rule exI[where x=2]) by auto
  subgoal using is_reduction_vc_sc .
  done

subsubsection \<open>\<open>3CNF-SAT\<close> To \<open>Independent Set\<close>\<close>

definition "mop_list_length xs = SPECT [ length xs \<mapsto> 1 ]"

definition "add_first_part F S =
  SPECT [ S \<union> {{(l1, i), (l2, i)} | l1 l2 i. i < length F \<and> l1 \<in> F ! i \<and> l2 \<in> F ! i \<and> l1 \<noteq> l2} \<mapsto> 3 * length F]"

definition "add_second_part F S =
  SPECT [ S \<union> {{(l1, i), (l2, j)} | l1 l2 i j.
      i < length F \<and> j < length F \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j \<and> conflict l1 l2}
       \<mapsto> 3 * length F * length F]"

definition sat_to_is :: "'a lit set list \<Rightarrow> (('a lit \<times> nat) set set \<times> nat) nrest" where
  "sat_to_is = (\<lambda>F. do {
      b \<leftarrow> SPECT [ (\<forall>cls \<in> set F. card cls = 3) \<mapsto> 1];
      if b then
        do {
          l \<leftarrow> mop_list_length F;
          S \<leftarrow> mop_set_empty_set;
          S \<leftarrow> add_first_part F S;
          S \<leftarrow> add_second_part F S;
          RETURNT ( S, l)
        }
      else RETURNT ( {}, 1 )
    })"

definition "size_SAT xs = length xs"
definition "sat_to_is_time n = 3 + 3 * n + 3 * n * n"

lemma sat_to_is_refines:
  "sat_to_is F \<le> SPEC (\<lambda>y. y = sat_is F) (\<lambda>_. sat_to_is_time (size_SAT F))"
  unfolding SPEC_def
  unfolding sat_to_is_def sat_is_def
      mop_list_length_def mop_set_empty_set_def add_first_part_def
      add_second_part_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC )
  by (auto simp: sat_to_is_time_def size_SAT_def one_enat_def)

definition "sat_to_is_space n = 9 * n + 9 * n * n"

lemma paf2: "{f l1 l2 i j |l1 l2 i j. i < k \<and> g l1 l2 i j}
    = (\<Union>i \<in> {..<k::nat}. {f l1 l2 i j |l1 l2 j. g l1 l2 i j}) "
  by auto

lemma paf: "{f l1 l2 i |l1 l2 i. i < j \<and> g l1 l2 i}
    = (\<Union>i \<in> {..<j::nat}. {f l1 l2 i |l1 l2. g l1 l2 i})"
  by auto

lemma brr:
  shows "{{f l1, g l2} |l1 l2. l1 \<in> X \<and> l2 \<in> Y \<and> h l1 l2} \<subseteq> (\<Union>x \<in> X. \<Union>y \<in> Y. {{f x, g y}})"
  (is "?lhs \<subseteq> ?rhs")
proof -
  have "?lhs \<subseteq> {{f l1, g l2} |l1 l2. l1 \<in> X \<and> l2 \<in> Y}" by auto
  also have "\<dots> = (\<Union>x \<in> X. {{f x, g l2} |l2. l2 \<in> Y})" by auto
  also have "\<dots> = ?rhs" by auto
  finally show ?thesis .
qed

lemma aaa: "\<forall>x\<in>X. card x = 3 \<Longrightarrow> x\<in>X \<Longrightarrow> finite x"
  using zero_neq_numeral by fastforce

lemma upperbounding_card3: "\<forall>x\<in>X. card x = 3 \<Longrightarrow> x\<in>X \<Longrightarrow> y\<in>X \<Longrightarrow>
        card {{f l1, g l2} |l1 l2. l1 \<in> x \<and> l2 \<in> y \<and> h l1 l2} \<le> 9"

      apply(rule order.trans)
       apply(rule card_mono) defer
        apply(rule brr)
       apply(rule order.trans) apply(rule card_Un)
      subgoal apply (rule finite_imageI) using aaa by auto
       apply(rule order.trans) apply(rule sum_image_le)
      subgoal using aaa by auto
        apply simp  apply(rule order.trans)
      apply(rule sum_mono[where g="\<lambda>_. 3"]) apply simp
        apply(rule order.trans) apply(rule card_Un)
      subgoal apply (rule finite_imageI) using aaa by auto
       apply(rule order.trans) apply(rule sum_image_le)
      subgoal using aaa by auto
         apply simp apply simp apply simp
      apply(rule finite_Union)
       apply (rule finite_imageI) using aaa by auto

lemma sat_to_is_size: "size_IS (sat_is p) \<le> sat_to_is_space (size_SAT p)"
  apply(auto simp: size_IS_def sat_is_def sat_to_is_space_def size_SAT_def)
  apply(rule order.trans[OF card_Un_le])
  apply(rule add_mono)
  subgoal
    apply(subst paf)
    apply(rule order.trans) apply(rule card_Un) apply simp
    apply(rule order.trans)
     apply(rule sum_image_le) apply simp
     apply simp
    apply(rule order.trans) apply(rule sum_mono[where g="(\<lambda>_. 9)"] )
    subgoal for i apply simp
      apply(rule upperbounding_card3) by auto
    apply simp
    done

  subgoal
    apply(subst paf2)
    apply(subst paf)
    apply(rule order.trans) apply(rule card_Un) apply simp
    apply(rule order.trans)
     apply(rule sum_image_le) apply simp apply simp
    apply(rule order.trans)
     apply(rule sum_mono[where g="\<lambda>_. 9 * length p"])
    subgoal apply simp
    apply(rule order.trans) apply(rule card_Un) apply simp
    apply(rule order.trans)
       apply(rule sum_image_le) apply simp apply simp
      apply(rule order.trans)
       apply(rule sum_mono[where g="\<lambda>_. 9"])
      subgoal
        apply simp apply(rule upperbounding_card3) by auto
      apply simp done
    subgoal apply simp done
    done
  done

theorem sat_to_is_ispolyred: "ispolyred sat_to_is three_cnf_sat independent_set size_SAT size_IS"
  unfolding ispolyred_def
  apply(rule exI[where x=sat_is])
  apply(rule exI[where x=sat_to_is_time])
  apply(rule exI[where x=sat_to_is_space])
  apply(safe)
  subgoal using sat_to_is_refines by blast
  subgoal using sat_to_is_size  by blast
  subgoal unfolding poly_def sat_to_is_time_def apply(rule exI[where x=2]) by auto
  subgoal unfolding poly_def sat_to_is_space_def apply(rule exI[where x=2]) by auto
  subgoal using is_reduction_sat_is .
  done

subsubsection \<open>Combination\<close>

theorem is_to_sc_ispolyred:
  "ispolyred (\<lambda>a. (is_to_vc a) \<bind> vc_to_sc) independent_set set_cover size_IS size_SC"
  by(rule sat_to_is_ispolyred is_to_vc_ispolyred vc_to_sc_ispolyred
      ispolyred_trans[OF is_to_vc_ispolyred vc_to_sc_ispolyred])

theorem sat_to_sc_ispolyred:
  "ispolyred (\<lambda>a. (sat_to_is a \<bind> is_to_vc) \<bind> vc_to_sc) three_cnf_sat set_cover size_SAT size_SC"
  by (rule ispolyred_trans [OF ispolyred_trans
        [OF sat_to_is_ispolyred is_to_vc_ispolyred] vc_to_sc_ispolyred])

end


header {* Backwards Compatibility for Version 1 *}
theory CollectionsV1
imports Collections
begin
  text {*
    This theory defines some stuff to establish (partial) backwards
    compatibility with ICF Version 1.
  *}

  (*
    TODO: Dirty hack to workaround a problem that occurs with sublocale here:
      When declaring

  sublocale poly_map_iteratei < v1_iteratei!: map_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)

      Any further

  interpretation StdMap hm_ops

    will fail with
*** exception TYPE raised (line 414 of "type.ML"):
*** Type variable "?'a" has two distinct sorts
*** ?'a\<Colon>type
*** ?'a\<Colon>hashable

  The problem seems difficult to track down, as it, e.g., does not iccur for
  sets.
*)

  attribute_setup locale_witness_add = {*
    Scan.succeed (Locale.witness_add)
    *} "Add witness for locale instantiation. HACK, use
      sublocale or interpretation whereever possible!"

  subsection {* Iterators *}
  text {* We define all the monomorphic iterator locales *}
  subsubsection "Set"
locale set_iteratei = finite_set \<alpha> invar for \<alpha> :: "'s \<Rightarrow> 'x set" and invar +
  fixes iteratei :: "'s \<Rightarrow> ('x, '\<sigma>) set_iterator"

  assumes iteratei_rule: "invar S \<Longrightarrow> set_iterator (iteratei S) (\<alpha> S)"
begin
  lemma iteratei_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
   apply (rule set_iterator_rule_P [OF iteratei_rule, of S I \<sigma>0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> \<alpha> S; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
    apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 c f P])
    apply simp_all
  done

  text {* Versions without break condition. *}
  lemma iterate_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I \<sigma>0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 f P])
    apply simp_all
  done
end

lemma set_iteratei_I :
assumes "\<And>s. invar s \<Longrightarrow> set_iterator (iti s) (\<alpha> s)"
shows "set_iteratei \<alpha> invar iti"
proof
  fix s
  assume invar_s: "invar s"
  from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (\<alpha> s)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (\<alpha> s)" .
qed

  locale set_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes iterateoi_rule:
      "invar s \<Longrightarrow> set_iterator_linord (iterateoi s) (\<alpha> s)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (\<alpha> m) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>\<alpha> m - it. j\<le>k;
        it \<subseteq> \<alpha> m;
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> \<alpha> m;
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>\<alpha> m - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>(\<alpha> m) - it. j\<le>k; it \<subseteq> (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_linord (itoi s) (\<alpha> s)"
  shows "set_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed

  (* Deprecated *)
  locale set_reverse_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> set_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>(\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>(\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m c f \<sigma>0)"
    using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in> (\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule reverse_iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_reverse_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_rev_linord (itoi s) (\<alpha> s)"
  shows "set_reverse_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed

  lemma (in poly_set_iteratei) v1_iteratei_impl:
    "set_iteratei \<alpha> invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_set_iterateoi) v1_iterateoi_impl:
    "set_iterateoi \<alpha> invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_set_rev_iterateoi) v1_reverse_iterateoi_impl:
    "set_reverse_iterateoi \<alpha> invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)

  declare (in poly_set_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_set_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_set_rev_iterateoi)
    v1_reverse_iterateoi_impl[locale_witness_add]

  (* Commented out, as it causes strange errors of the kind:
    Type variable "?'a" has two distinct sorts

  sublocale poly_set_iteratei < v1_iteratei!: set_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_set_iterateoi < v1_iteratei!: set_iterateoi \<alpha> invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_set_rev_iterateoi
    < v1_iteratei!: set_reverse_iterateoi \<alpha> invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

subsubsection "Map"
locale map_iteratei = finite_map \<alpha> invar for \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v" and invar +
  fixes iteratei :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"

  assumes iteratei_rule: "invar m \<Longrightarrow> map_iterator (iteratei m) (\<alpha> m)"
begin

  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (\<alpha> m)) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                    \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes
      "invar m"
      "I {} \<sigma>0"
      "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
          \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
      "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
               \<not> (c \<sigma>);
               I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator (iti m) (\<alpha> m)"
  shows "map_iteratei \<alpha> invar iti"
proof
  fix m
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (\<alpha> m)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
qed

  locale map_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_linord (iterateoi m) (\<alpha> m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_linord (itoi m) (\<alpha> m)"
  shows "map_iterateoi \<alpha> invar itoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  locale map_reverse_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m c f \<sigma>0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_rev_linord (ritoi m) (\<alpha> m)"
  shows "map_reverse_iterateoi \<alpha> invar ritoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  lemma (in poly_map_iteratei) v1_iteratei_impl:
    "map_iteratei \<alpha> invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_map_iterateoi) v1_iterateoi_impl:
    "map_iterateoi \<alpha> invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_map_rev_iterateoi) v1_reverse_iterateoi_impl:
    "map_reverse_iterateoi \<alpha> invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)

  declare (in poly_map_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_map_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_map_rev_iterateoi)
    v1_reverse_iterateoi_impl[locale_witness_add]

  (*
  sublocale poly_map_iteratei < v1_iteratei!: map_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_map_iterateoi < v1_iteratei!: map_iterateoi \<alpha> invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_map_rev_iterateoi
    < v1_iteratei!: map_reverse_iterateoi \<alpha> invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

  subsection {* Concrete Operation Names *}
  text {* We define abbreviations to recover the @{text "xx_op"}-names *}

  (* TODO: This may take long, as Local_Theory.abbrev seems to be really slow *)
  local_setup {* let
    val thy = @{theory}
    val ctxt = Proof_Context.init_global thy;
    val pats = [
    "hs","hm",
    "rs","rm",
    "ls","lm","lsi","lmi","lsnd","lss",
    "ts","tm",
    "ias","iam",
    "ahs","ahm",
    "bino",
    "fifo",
    "ft",
    "alprioi",
    "aluprioi",
    "skew"
    ];

    val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest
    val clist = Name_Space.extern_entries ctxt const_space constants |> map (apfst #1)

    fun abbrevs_for pat = clist
    |> map_filter (fn (n,_) => case Long_Name.explode n of
        [_,prefix,opname] =>
          if prefix = pat then let
              val aname = prefix ^ "_" ^ opname
              val rhs = Proof_Context.read_term_abbrev ctxt n
            in SOME (aname,rhs) end
          else NONE
      | _ => NONE);

    fun do_abbrevs pat lthy = let
      val abbrevs = abbrevs_for pat;
    in
      case abbrevs of [] => (warning ("No stuff found for "^pat); lthy)
      | _ => let
        (*val _ = tracing ("Defining " ^ pat ^ "_xxx ...");*)
        val lthy = fold (fn (name,rhs) =>
          Local_Theory.abbrev
            Syntax.mode_input
            ((Binding.name name,Mixfix.NoSyn),rhs) #> #2
        ) abbrevs lthy
        (*val _ = tracing "Done";*)
      in lthy end
    end
  in
    fold do_abbrevs pats
  end

    *}

lemmas hs_correct = hs.correct
lemmas hm_correct = hm.correct
lemmas rs_correct = rs.correct
lemmas rm_correct = rm.correct
lemmas ls_correct = ls.correct
lemmas lm_correct = lm.correct
lemmas lsi_correct = lsi.correct
lemmas lmi_correct = lmi.correct
lemmas lsnd_correct = lsnd.correct
lemmas lss_correct = lss.correct
lemmas ts_correct = ts.correct
lemmas tm_correct = tm.correct
lemmas ias_correct = ias.correct
lemmas iam_correct = iam.correct
lemmas ahs_correct = ahs.correct
lemmas ahm_correct = ahm.correct
lemmas bino_correct = bino.correct
lemmas fifo_correct = fifo.correct
lemmas ft_correct = ft.correct
lemmas alprioi_correct = alprioi.correct
lemmas aluprioi_correct = aluprioi.correct
lemmas skew_correct = skew.correct

locale list_enqueue = list_appendr
locale list_dequeue = list_removel

locale list_push = list_appendl
locale list_pop = list_remover
locale list_top = list_leftmost
locale list_bot = list_rightmost

instantiation rbt :: ("{equal,linorder}",equal) equal
begin
  (*definition equal_rbt :: "('a,'b) RBT.rbt \<Rightarrow> _" where "equal_rbt \<equiv> op ="*)

  definition "equal_class.equal (r :: ('a, 'b) rbt) r'
    == RBT.impl_of r = RBT.impl_of r'"

  instance
    apply intro_classes
    apply (simp add: equal_rbt_def RBT.impl_of_inject)
    done
end

end


theory ArrSum
imports "../l4v/tools/autocorres/AutoCorres"
begin
text{*

Author: Dan DaCosta
Description: A proof of the correctness, with respect to a function specification, of a C function
that sums all unsigned integers in an array. In other words, it is shown that a C function and
Isabelle function, when applied to the same input modulo a mapping function, return the same value.
Note that correctness in sense permits integer overflow.

*}
install_C_file arrsum.c
autocorres[ts_rules = nondet, heap_abs_syntax ] arrsum.c
text{*

We could use the "unsigned_word_abs" conversion on this function. When done, a proof obligation
that the while loop body statement associated with aggregating the sum never overflows must be
discharged. Instead we have opted to prove correctness via equivalence with a functional
specification that also permits overflow making the utility of such a conversion low.

*}

context arrsum begin

lemma ptr_add_assoc [simp]: "p +\<^sub>p (i + j) = p +\<^sub>p i +\<^sub>p j"
 by (simp add: CTypesDefs.ptr_add_def distrib_right)

fun the_array :: "lifted_globals \<Rightarrow> 32 word ptr \<Rightarrow> 32 word list \<Rightarrow> bool" where
"the_array s a [] = True"
|"the_array s a (w # ws) = (w = s[a] \<and> is_valid_w32 s a \<and> the_array s (a +\<^sub>p 1) ws)"

lemma drop_extend_eq:"0 < n \<Longrightarrow> drop (n-1) xs = drop n (x # xs)"
 apply (induction n) by auto

lemma drop_unat_extend_eq:"0 < (n::32 word) \<Longrightarrow> drop (unat (n-1)) xs = drop (unat n) (x # xs)"
by (metis arrsum.drop_extend_eq unat_0 unat_minus_one unat_mono word_gt_0)

lemma the_array_offsets:
 "\<lbrakk>the_array s a ws; (i::32 word) < of_nat (length ws)\<rbrakk> \<Longrightarrow> the_array s (a +\<^sub>p uint i) (drop (unat i) ws)"
proof(induction ws arbitrary: a i)
  case Nil
  thus ?case by auto
next
  case (Cons w ws)
  then have "0 = i \<or> 0 < i" using word_neq_0_conv by blast
  thus ?case
  proof
    assume "0 = i"
    thus ?case using Cons by auto
  next
    assume a:"0 < i"
    then have "i - 1 < of_nat (length ws)"
      by (metis (no_types) Cons.prems(2) add.commute gt0_iff_gem1 le_less_trans length_Cons
          not_less plus_one_helper semiring_1_class.of_nat_simps(2))
    then have "the_array s (a +\<^sub>p 1 +\<^sub>p uint (i - 1)) (drop (unat (i - 1)) ws)" using Cons by auto
    then have "the_array s (a +\<^sub>p uint i) (drop (unat (i - 1)) ws)"
    by (metis (no_types, hide_lams) Suc_unat_minus_one a arrsum.ptr_add_assoc of_nat_Suc uint_nat word_not_simps(1))
    thus ?case using drop_unat_extend_eq[OF a,of ws w] by auto
  qed
qed

lemma drop_not_empty:"i < length xs \<Longrightarrow> drop i xs \<noteq> []"
by auto

lemma the_array_all_valid:
 "\<lbrakk>the_array s a ws; (i::32 word) < of_nat (length ws)\<rbrakk> \<Longrightarrow> is_valid_w32 s (a +\<^sub>p uint i)"
using the_array_offsets drop_not_empty by (metis arrsum.the_array.elims(2) unat_less_helper)

lemma the_array_list_corres:
"\<lbrakk>the_array s a ws; (i::32 word) < of_nat (length ws)\<rbrakk> \<Longrightarrow> s[a +\<^sub>p uint i] = ws ! (unat i)"
using the_array_offsets drop_not_empty
  by (metis (no_types, hide_lams) arrsum.the_array.simps(2) drop_0 hd_drop_conv_nth
      length_greater_0_conv list.exhaust nth_Cons_0 unat_less_helper)

lemma word_ge_zero[simp]:"(x::32 word) = 0 \<or> 0 < x"
using word_neq_0_conv by blast

lemma growing_listsum:"\<lbrakk>length ws \<le> UINT_MAX; (iw::32 word) < of_nat (length ws)\<rbrakk>
          \<Longrightarrow> listsum (take (unat iw) ws) + (ws ! unat iw) = listsum (take (unat (iw + 1)) ws)"
proof -
  assume a1:"length ws \<le> UINT_MAX" and a2:"(iw::32 word) < of_nat (length ws)"
  then have h1:"unat iw < length ws" by (simp add: unat_less_helper)
  have "take (unat (iw + 1)) ws = take (unat (iw + 1)) ws" by auto
  then have "take (unat iw) ws @ [ws ! unat iw] = take (unat (iw + 1)) ws"
    by (metis less_irrefl word_1_0  word_zero_le sym[OF take_Suc_conv_app_nth[OF h1]] a2 unatSuc2)
  then have "listsum (take (unat iw) ws @ [ws ! unat iw]) = listsum (take (unat (iw + 1)) ws)"
    by auto
  thus ?thesis by auto
qed

(* I cannot seem to simplify this proof anything further ... very strange. *)
lemma unat_of_nat32_alt:"x \<le> UINT_MAX \<Longrightarrow> unat ((of_nat x)::32 word) = x"
proof -
  assume "x \<le> UINT_MAX"
  then have "x \<le> 2 ^ 32 - 1" using UINT_MAX_def by auto
  then have "x < 2 ^ 32" by auto
  thus ?thesis using unat_of_nat32 word_bits_conv by auto
qed

lemma arrsum_correct:
  "\<lbrace> \<lambda>s. the_array s a ws \<and> length ws \<le> UINT_MAX \<and> s = s'\<rbrace>
   arrsum' a (of_nat (length ws))
   \<lbrace> \<lambda>r s. r = listsum ws \<and> s = s' \<rbrace>!"
apply (rule validNF_assume_pre)
apply (unfold arrsum'_def)
apply (subst whileLoop_add_inv
  [where
    I = "\<lambda> (j,sum) s.
      s = s'
      \<and> j \<le> of_nat (length ws)
      \<and> sum = listsum (take (unat j) ws)"
    and M = "\<lambda>((j,_),_).  length ws - unat j"])
apply wp
   apply clarsimp
   (* Obligation from loop axiom plus obligation for measure decrease. *)
   apply (auto simp add: inc_le diff_less_mono2 unat_less_helper word_1_0 the_array_all_valid
          the_array_list_corres intro: growing_listsum)[1]
   (* Invariant implies postcondition. *)
  using unat_of_nat32_alt apply auto[1]
  (* Precondition implies invariant. *)
 apply auto
done

end

end


theory nmap_assign
imports
  nmap_expr
begin

type_synonym '\<alpha> proc        = " (bool, '\<alpha> \<times> '\<alpha>) uexpr"
type_synonym ('\<alpha>, '\<beta>) urel  = " (bool, '\<alpha> \<times> '\<beta>) uexpr"

subsection \<open>assignment statement\<close>

consts uassigns :: "'a usubst \<Rightarrow> 'b" ("\<langle>_\<rangle>\<^sub>a")
lift_definition assigns_r :: "'\<alpha> usubst \<Rightarrow> '\<alpha> proc "
  is "\<lambda> \<sigma> (b, b'). b' = \<sigma>(b)" .
adhoc_overloading
  uassigns assigns_r

consts uskip :: "'a" ("II")
definition skip_r :: " '\<alpha> proc " where "skip_r = assigns_r id"
print_theorems
adhoc_overloading
  uskip skip_r

syntax
  \<comment> \<open> Single and multiple assignement \<close>
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> proc"  ("'(_') := '(_')")
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> proc"  (infixr ":=" 62)
  \<comment> \<open> Substitution constructor \<close>
  "_mk_usubst"      :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"

translations
  "_mk_usubst \<sigma> (_svid_unit x) v" \<rightleftharpoons> "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" \<rightleftharpoons> "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST uassigns (_mk_usubst (CONST id) xs vs)"
  "_assignment x v" <= "CONST uassigns (CONST subst_upd (CONST id) x v)"
  "_assignment x v" <= "_assignment (_spvar x) v"
  "x,y := u,v" <= "CONST uassigns (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"

lemma " \<langle>[y \<mapsto>\<^sub>s f]\<rangle>\<^sub>a =  y := f "
  by (simp add: pr_var_def)

(***    test begin    ***)
lemma assign_skip:
  assumes "vwb_lens x"
  shows "(x := &x) = II"
proof -
  have " [x \<mapsto>\<^sub>s var x] = id"
    by (simp add: assms usubst_upd_var_id)
  then show ?thesis
    by (simp add: assms skip_r_def usubst_upd_var_id)
qed

lemma assigns_simul2:
  assumes "vwb_lens x"
  shows "(x,x) := (u,v) = (x := v)"
  by (simp add: assms  usubst_upd_idem)

lemma assign_simul1:
  assumes "vwb_lens y" "x \<bowtie> y"
  shows "(x,y) := (1+1, &y) = (x := 2)"
  by (metis assms(1) assms(2) one_add_one pr_var_def usubst_upd_comm usubst_upd_pr_var_id)

(**

consts useq     :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 61)
lift_definition seqr::"('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<beta>, '\<gamma>) urel \<Rightarrow>  (bool,'\<alpha> \<times> '\<gamma>) uexpr"
is "\<lambda> P Q b. b \<in> ({p. P p} O {q. Q q})" .
adhoc_overloading
  useq seqr

lemma assigns_comp: "(assigns_r f ;; assigns_r g) = assigns_r (g \<circ> f)"

(***    test end    ***)

subsection \<open> nchoice statement  \<close>

class nchoice =
  fixes nchoice :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)
  assumes nch_assoc   : "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
      and nch_commute : "x \<sqinter> y = y \<sqinter> x"
      and nch_idemp   : "(x \<sqinter> x) = x"

      and nch_skip_left: " II \<sqinter> x = x"
      and nch_skip_right: "x \<sqinter>  II = x"
**)

(***
lemma (in nchoice) "(x:=3)  \<sqinter> (y:=4) =  (y:=4)  \<sqinter>  (x:=3)"
  by (simp add: nch_commute)

lemma " (a:=3)  \<sqinter> (b:=4) =  (b:=4)  \<sqinter>  (a:=3)  "
'a  = 'b state_scheme

subsection \<open> if-than-else statement  \<close>

definition ifprog :: " 'a  \<Rightarrow> bool \<Rightarrow> 'a  \<Rightarrow> 'a "  ("(_ \<triangleleft> _  \<triangleright>\<^sub>\<p>/ _)" [52,0,53] 52)
  where "x  \<triangleleft> P \<triangleright>\<^sub>\<p> y \<equiv> (THE z::'a . (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"

theorem ifprog_idemp : "x \<triangleleft> boole \<triangleright>\<^sub>\<p> x = x"
  by (simp add: ifprog_def)
***)

end