section "Kruskal Implementation"

theory Kruskal_Impl
imports Kruskal.Kruskal_Refine Refine_Imperative_HOL.IICF
begin

subsection \<open>Refinement III: concrete edges\<close>

text \<open>Given a concrete representation of edges and their endpoints as a pair, we refine
  Kruskal's algorithm to work on these concrete edges.\<close>

locale Kruskal_concrete = Kruskal_interface E V vertices  joins  forest connected  weight
  for E V vertices joins forest connected  and weight :: "'edge \<Rightarrow> int"  +
  fixes
    \<alpha> :: "'cedge \<Rightarrow> 'edge"
    and endpoints :: "'cedge \<Rightarrow> ('a*'a) nres"
  assumes
    endpoints_refine: "\<alpha> xi = x \<Longrightarrow> endpoints xi \<le> \<Down> Id (a_endpoints x)"
begin

definition wsorted' where "wsorted' == sorted_wrt (\<lambda>x y. weight (\<alpha> x) \<le> weight (\<alpha> y))"

lemma wsorted_map\<alpha>[simp]: "wsorted' s \<Longrightarrow> wsorted (map \<alpha> s)"
  by(auto simp: wsorted'_def sorted_wrt_map)

definition "obtain_sorted_carrier' == SPEC (\<lambda>L. wsorted' L \<and> \<alpha> ` set L = E)"

abbreviation concrete_edge_rel :: "('cedge  \<times> 'edge) set" where
  "concrete_edge_rel \<equiv> br \<alpha> (\<lambda>_. True)"

lemma obtain_sorted_carrier'_refine:
  "(obtain_sorted_carrier', obtain_sorted_carrier) \<in> \<langle>\<langle>concrete_edge_rel\<rangle>list_rel\<rangle>nres_rel"
  unfolding obtain_sorted_carrier'_def obtain_sorted_carrier_def
  apply refine_vcg
  apply (auto intro!: RES_refine simp:     )
  subgoal for s apply(rule exI[where x="map \<alpha> s"])
    by(auto simp: map_in_list_rel_conv in_br_conv)
  done

definition kruskal2
  where "kruskal2 \<equiv> do {
    l \<leftarrow> obtain_sorted_carrier';
    let initial_union_find = per_init V;
    (per, spanning_forest) \<leftarrow> nfoldli l (\<lambda>_. True)
        (\<lambda>ce (uf, T). do {
            ASSERT (\<alpha> ce \<in> E);
            (a,b) \<leftarrow> endpoints ce;
            ASSERT (a\<in>V \<and> b\<in>V \<and> a \<in> Domain uf \<and> b \<in> Domain uf );
            if \<not> per_compare uf a b then
              do {
                let uf = per_union uf a b;
                ASSERT (ce \<notin> set T);
                RETURN (uf, T@[ce])
              }
            else
              RETURN (uf,T)
        }) (initial_union_find, []);
        RETURN spanning_forest
      }"

lemma lst_graph_rel_empty[simp]: "([], {}) \<in> \<langle>concrete_edge_rel\<rangle>list_set_rel"
  unfolding list_set_rel_def apply(rule relcompI[where b="[]"])
  by (auto simp add: in_br_conv)

lemma loop_initial_rel:
  "((per_init V, []), per_init V, {}) \<in> Id \<times>\<^sub>r \<langle>concrete_edge_rel\<rangle>list_set_rel"
  by simp

lemma concrete_edge_rel_list_set_rel:
  "(a, b) \<in> \<langle>concrete_edge_rel\<rangle>list_set_rel \<Longrightarrow> \<alpha> ` (set a) = b"
  by (auto simp: in_br_conv list_set_rel_def dest: list_relD2)

theorem kruskal2_refine: "(kruskal2, kruskal1)\<in>\<langle>\<langle>concrete_edge_rel\<rangle>list_set_rel\<rangle>nres_rel"
  unfolding kruskal1_def kruskal2_def Let_def
  apply (refine_rcg obtain_sorted_carrier'_refine[THEN nres_relD]
                    endpoints_refine loop_initial_rel)
  by (auto intro!: list_set_rel_append
            dest: concrete_edge_rel_list_set_rel
            simp: in_br_conv)

end

subsection \<open>Refinement to Imperative/HOL with Sepref-Tool\<close>

text \<open>Given implementations for the operations of getting a list of concrete edges
  and getting the endpoints of a concrete edge we synthesize Kruskal in Imperative/HOL.\<close>

locale Kruskal_Impl = Kruskal_concrete E V vertices joins forest connected weight \<alpha> endpoints
  for E V vertices joins forest connected and weight :: "'edge \<Rightarrow> int"
    and \<alpha> and endpoints :: "nat \<times> int \<times> nat \<Rightarrow> (nat \<times> nat) nres"
    +
  fixes getEdges  :: "(nat \<times> int \<times> nat) list nres"
    and getEdges_impl :: "(nat \<times> int \<times> nat) list Heap"
    and superE :: "(nat \<times> int \<times> nat) set"
    and endpoints_impl :: "(nat \<times> int \<times> nat) \<Rightarrow> (nat \<times> nat) Heap"
  assumes
    getEdges_refine: "getEdges \<le> SPEC (\<lambda>L. \<alpha> ` set L = E
                            \<and> (\<forall>(a,wv,b)\<in>set L.  weight (\<alpha> (a,wv,b)) = wv) \<and> set L \<subseteq> superE)"
    and
    getEdges_impl: "(uncurry0 getEdges_impl, uncurry0 getEdges)
                     \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    and
    max_node_is_Max_V: "E = \<alpha> ` set la \<Longrightarrow> max_node la = Max (insert 0 V)"
    and
    endpoints_impl: "( endpoints_impl,  endpoints)
                      \<in> (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)\<^sup>k \<rightarrow>\<^sub>a (nat_assn \<times>\<^sub>a nat_assn)"
begin

  lemma this_loc: "Kruskal_Impl E V vertices  joins  forest connected  weight
            \<alpha> endpoints getEdges getEdges_impl superE    endpoints_impl" by unfold_locales

  subsubsection \<open>Refinement IV: given an edge set\<close>

  text \<open>We now assume to have an implementation of the operation to obtain a list of the edges of
    a graph. By sorting this list we refine @{term obtain_sorted_carrier'}.\<close>

  definition "obtain_sorted_carrier'' = do {
      l \<leftarrow> SPEC (\<lambda>L.  \<alpha> ` set L = E
                              \<and> (\<forall>(a,wv,b)\<in>set L.  weight (\<alpha> (a,wv,b)) = wv) \<and> set L \<subseteq> superE);
      SPEC (\<lambda>L. sorted_wrt edges_less_eq L \<and> set L = set l)
  }"

  lemma wsorted'_sorted_wrt_edges_less_eq:
    assumes "\<forall>(a,wv,b)\<in>set s.  weight (\<alpha> (a,wv,b)) = wv"
        "sorted_wrt edges_less_eq s"
    shows "wsorted' s"
    using assms apply -
    unfolding wsorted'_def   unfolding edges_less_eq_def
    apply(rule sorted_wrt_mono_rel )
    by (auto simp: case_prod_beta)

  lemma obtain_sorted_carrier''_refine:
    "(obtain_sorted_carrier'', obtain_sorted_carrier') \<in> \<langle>Id\<rangle>nres_rel"
    unfolding obtain_sorted_carrier''_def obtain_sorted_carrier'_def
    apply refine_vcg
     apply(auto simp: in_br_conv   wsorted'_sorted_wrt_edges_less_eq
        distinct_map map_in_list_rel_conv)
    done

  definition "obtain_sorted_carrier''' =
        do {
      l \<leftarrow> getEdges;
      RETURN (quicksort_by_rel edges_less_eq [] l, max_node l)
  }"

  definition "add_size_rel   = br fst (\<lambda>(l,n). n= Max (insert 0 V))"

  lemma obtain_sorted_carrier'''_refine:
    "(obtain_sorted_carrier''', obtain_sorted_carrier'') \<in> \<langle>add_size_rel\<rangle>nres_rel"
    unfolding obtain_sorted_carrier'''_def obtain_sorted_carrier''_def
    apply (refine_rcg getEdges_refine)
    by (auto intro!: RETURN_SPEC_refine simp: quicksort_by_rel_distinct sort_edges_correct
        add_size_rel_def in_br_conv  max_node_is_Max_V
        dest!: distinct_mapI)

  lemmas osc_refine =  obtain_sorted_carrier'''_refine[FCOMP obtain_sorted_carrier''_refine,
                                                        to_foparam, simplified]

  definition kruskal3 :: "(nat \<times> int \<times> nat) list nres"
    where "kruskal3  \<equiv> do {
      (sl,mn) \<leftarrow> obtain_sorted_carrier''';
      let initial_union_find = per_init' (mn + 1);
      (per, spanning_forest) \<leftarrow> nfoldli sl (\<lambda>_. True)
          (\<lambda>ce (uf, T). do {
              ASSERT (\<alpha> ce \<in> E);
              (a,b) \<leftarrow> endpoints ce;
              ASSERT (a \<in> Domain uf \<and> b \<in> Domain uf);
              if \<not> per_compare uf a b then
                do {
                  let uf = per_union uf a b;
                  ASSERT (ce\<notin>set T);
                  RETURN (uf, T@[ce])
                }
              else
                RETURN (uf,T)
          }) (initial_union_find, []);
          RETURN spanning_forest
        }"

  lemma endpoints_spec: "endpoints ce \<le> SPEC (\<lambda>_. True)"
    by(rule order.trans[OF endpoints_refine], auto)

  lemma  kruskal3_subset:
    shows "kruskal3 \<le>\<^sub>n SPEC (\<lambda>T. distinct T \<and> set T \<subseteq> superE )"
    unfolding kruskal3_def obtain_sorted_carrier'''_def
    apply (refine_vcg getEdges_refine[THEN leof_lift] endpoints_spec[THEN leof_lift]
        nfoldli_leof_rule[where I="\<lambda>_ _ (_, T). distinct T \<and>  set T \<subseteq> superE "])
             apply auto
    subgoal
      by (metis append_self_conv in_set_conv_decomp set_quicksort_by_rel subset_iff)
    subgoal
      by blast
    done

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2
       \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
     apply blast
    apply force
    done

  lemma per_initN_refine: "(per_init' (Max (insert 0 V) + 1), per_init V) \<in> per_supset_rel"
    unfolding per_supset_rel_def per_init'_def per_init_def max_node_def
    by (auto simp: less_Suc_eq_le  )

  theorem kruskal3_refine: "(kruskal3, kruskal2)\<in>\<langle>Id\<rangle>nres_rel"
    unfolding kruskal2_def kruskal3_def Let_def
    apply (refine_rcg osc_refine[THEN nres_relD]   )
               supply RELATESI[where R="per_supset_rel::(nat per \<times> _) set", refine_dref_RELATES]
               apply refine_dref_type
    subgoal by (simp add: add_size_rel_def in_br_conv)
    subgoal using per_initN_refine by (simp add: add_size_rel_def in_br_conv)
    by (auto simp add: add_size_rel_def in_br_conv per_supset_compare per_supset_union
        dest: per_supset_rel_dom
        simp del: per_compare_def )

  subsubsection \<open>Synthesis of Kruskal by SepRef\<close>

  lemma [sepref_import_param]: "(sort_edges,sort_edges)\<in>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel"
    by simp
  lemma [sepref_import_param]: "(max_node, max_node) \<in> \<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> nat_rel" by simp

  sepref_register "getEdges" :: "(nat \<times> int \<times> nat) list nres"
  sepref_register "endpoints" :: "(nat \<times> int \<times> nat) \<Rightarrow> (nat*nat) nres"

  declare getEdges_impl [sepref_fr_rules]
  declare endpoints_impl [sepref_fr_rules]

  schematic_goal kruskal_impl:
    "(uncurry0 ?c, uncurry0 kruskal3 ) \<in> (unit_assn)\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    unfolding kruskal3_def obtain_sorted_carrier'''_def
    unfolding sort_edges_def[symmetric]
    apply (rewrite at "nfoldli _ _ _ (_,rewrite_HOLE)" HOL_list.fold_custom_empty)
    by sepref

  concrete_definition (in -) kruskal uses Kruskal_Impl.kruskal_impl
  prepare_code_thms (in -) kruskal_def
  lemmas kruskal_refine = kruskal.refine[OF this_loc]

  txt \<open>These should probably be moved to \<^locale>\<open>Kruskal_interface\<close>'s initial usage in \<^theory>\<open>Kruskal.Kruskal\<close>...\<close>
  abbreviation (in Kruskal_interface) "MSF == minBasis"
  abbreviation (in Kruskal_interface) "SpanningForest == basis"
  lemmas (in Kruskal_interface) SpanningForest_def = basis_def
  lemmas (in Kruskal_interface) MSF_def = minBasis_def

  lemmas kruskal3_ref_spec_ = kruskal3_refine[FCOMP kruskal2_refine, FCOMP kruskal1_refine,
      FCOMP kruskal0_refine,
      FCOMP minWeightBasis_refine]

  lemma kruskal3_ref_spec':
    "(uncurry0 kruskal3, uncurry0 (SPEC (\<lambda>r. MSF (\<alpha> ` set r)))) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    unfolding fref_def
    apply auto
    apply(rule nres_relI)
    apply(rule order.trans[OF  kruskal3_ref_spec_[unfolded fref_def, simplified,  THEN nres_relD]])
    by (auto simp: conc_fun_def list_set_rel_def in_br_conv dest!: list_relD2)

  lemma kruskal3_ref_spec:
   "(uncurry0 kruskal3,
      uncurry0 (SPEC (\<lambda>r. distinct r \<and> set r \<subseteq> superE \<and>  MSF (\<alpha> ` set r))))
      \<in> unit_rel \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    unfolding fref_def
    apply auto
    apply(rule nres_relI)
    apply simp
    using SPEC_rule_conj_leofI2[OF kruskal3_subset kruskal3_ref_spec'
              [unfolded fref_def, simplified,  THEN nres_relD, simplified]]
    by simp

  lemma [fcomp_norm_simps]: "list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: list_assn_pure_conv)

  lemmas kruskal_ref_spec = kruskal_refine[FCOMP kruskal3_ref_spec]

  text \<open>The final correctness lemma for Kruskal's algorithm. \<close>

  lemma kruskal_correct_forest:
    shows "<emp> kruskal getEdges_impl endpoints_impl ()
             <\<lambda>r. \<up>( distinct r \<and> set r \<subseteq> superE \<and> MSF (set (map \<alpha> r)))>\<^sub>t"
  proof -
    show ?thesis
      using kruskal_ref_spec[to_hnr]
      unfolding hn_refine_def
      apply clarsimp
      apply (erule cons_post_rule)
      by (sep_auto simp: hn_ctxt_def pure_def list_set_rel_def in_br_conv dest: list_relD)
  qed

end \<comment> \<open>locale @{text Kruskal_Impl}\<close>

end


(*  Title:      ZF/AC/AC7_AC9.thy
    Author:     Krzysztof Grabczewski

The proofs needed to state that AC7, AC8 and AC9 are equivalent to the previous
instances of AC.
*)

theory AC7_AC9
imports AC_Equiv
begin

(* ********************************************************************** *)
(* Lemmas used in the proofs AC7 \<Longrightarrow> AC6 and AC9 \<Longrightarrow> AC1                  *)
(*  - Sigma_fun_space_not0                                                *)
(*  - Sigma_fun_space_eqpoll                                              *)
(* ********************************************************************** *)

lemma Sigma_fun_space_not0: "\<lbrakk>0\<notin>A; B \<in> A\<rbrakk> \<Longrightarrow> (nat->\<Union>(A)) * B \<noteq> 0"
by (blast dest!: Sigma_empty_iff [THEN iffD1] Union_empty_iff [THEN iffD1])

lemma inj_lemma:
        "C \<in> A \<Longrightarrow> (\<lambda>g \<in> (nat->\<Union>(A))*C.
                (\<lambda>n \<in> nat. if(n=0, snd(g), fst(g)`(n #- 1))))
                \<in> inj((nat->\<Union>(A))*C, (nat->\<Union>(A)) ) "
  unfolding inj_def
apply (rule CollectI)
apply (fast intro!: lam_type if_type apply_type fst_type snd_type, auto)
apply (rule fun_extension, assumption+)
apply (drule lam_eqE [OF _ nat_succI], assumption, simp)
apply (drule lam_eqE [OF _ nat_0I], simp)
done

lemma Sigma_fun_space_eqpoll:
     "\<lbrakk>C \<in> A; 0\<notin>A\<rbrakk> \<Longrightarrow> (nat->\<Union>(A)) * C \<approx> (nat->\<Union>(A))"
apply (rule eqpollI)
apply (simp add: lepoll_def)
apply (fast intro!: inj_lemma)
apply (fast elim!: prod_lepoll_self not_sym [THEN not_emptyE] subst_elem
            elim: swap)
done

(* ********************************************************************** *)
(* AC6 \<Longrightarrow> AC7                                                            *)
(* ********************************************************************** *)

lemma AC6_AC7: "AC6 \<Longrightarrow> AC7"
by (unfold AC6_def AC7_def, blast)

(* ********************************************************************** *)
(* AC7 \<Longrightarrow> AC6, Rubin & Rubin p. 12, Theorem 2.8                          *)
(* The case of the empty family of sets added in order to complete        *)
(* the proof.                                                             *)
(* ********************************************************************** *)

lemma lemma1_1: "y \<in> (\<Prod>B \<in> A. Y*B) \<Longrightarrow> (\<lambda>B \<in> A. snd(y`B)) \<in> (\<Prod>B \<in> A. B)"
by (fast intro!: lam_type snd_type apply_type)

lemma lemma1_2:
     "y \<in> (\<Prod>B \<in> {Y*C. C \<in> A}. B) \<Longrightarrow> (\<lambda>B \<in> A. y`(Y*B)) \<in> (\<Prod>B \<in> A. Y*B)"
apply (fast intro!: lam_type apply_type)
done

lemma AC7_AC6_lemma1:
     "(\<Prod>B \<in> {(nat->\<Union>(A))*C. C \<in> A}. B) \<noteq> 0 \<Longrightarrow> (\<Prod>B \<in> A. B) \<noteq> 0"
by (fast intro!: equals0I lemma1_1 lemma1_2)

lemma AC7_AC6_lemma2: "0 \<notin> A \<Longrightarrow> 0 \<notin> {(nat -> \<Union>(A)) * C. C \<in> A}"
by (blast dest: Sigma_fun_space_not0)

lemma AC7_AC6: "AC7 \<Longrightarrow> AC6"
  unfolding AC6_def AC7_def
apply (rule allI)
apply (rule impI)
apply (case_tac "A=0", simp)
apply (rule AC7_AC6_lemma1)
apply (erule allE)
apply (blast del: notI
             intro!: AC7_AC6_lemma2 intro: eqpoll_sym eqpoll_trans
                    Sigma_fun_space_eqpoll)
done

(* ********************************************************************** *)
(* AC1 \<Longrightarrow> AC8                                                            *)
(* ********************************************************************** *)

lemma AC1_AC8_lemma1:
        "\<forall>B \<in> A. \<exists>B1 B2. B=\<langle>B1,B2\<rangle> \<and> B1 \<approx> B2
        \<Longrightarrow> 0 \<notin> { bij(fst(B),snd(B)). B \<in> A }"
apply (unfold eqpoll_def, auto)
done

lemma AC1_AC8_lemma2:
     "\<lbrakk>f \<in> (\<Prod>X \<in> RepFun(A,p). X); D \<in> A\<rbrakk> \<Longrightarrow> (\<lambda>x \<in> A. f`p(x))`D \<in> p(D)"
apply (simp, fast elim!: apply_type)
done

lemma AC1_AC8: "AC1 \<Longrightarrow> AC8"
  unfolding AC1_def AC8_def
apply (fast dest: AC1_AC8_lemma1 AC1_AC8_lemma2)
done

(* ********************************************************************** *)
(* AC8 \<Longrightarrow> AC9                                                            *)
(*  - this proof replaces the following two from Rubin & Rubin:           *)
(*    AC8 \<Longrightarrow> AC1 and AC1 \<Longrightarrow> AC9                                         *)
(* ********************************************************************** *)

lemma AC8_AC9_lemma:
     "\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1 \<approx> B2
      \<Longrightarrow> \<forall>B \<in> A*A. \<exists>B1 B2. B=\<langle>B1,B2\<rangle> \<and> B1 \<approx> B2"
by fast

lemma AC8_AC9: "AC8 \<Longrightarrow> AC9"
  unfolding AC8_def AC9_def
apply (intro allI impI)
apply (erule allE)
apply (erule impE, erule AC8_AC9_lemma, force)
done

(* ********************************************************************** *)
(* AC9 \<Longrightarrow> AC1                                                            *)
(* The idea of this proof comes from "Equivalents of the Axiom of Choice" *)
(* by Rubin & Rubin. But (x * y) is not necessarily equipollent to        *)
(* (x * y) \<union> {0} when y is a set of total functions acting from nat to   *)
(* \<Union>(A) -- therefore we have used the set (y * nat) instead of y.     *)
(* ********************************************************************** *)

lemma snd_lepoll_SigmaI: "b \<in> B \<Longrightarrow> X \<lesssim> B \<times> X"
by (blast intro: lepoll_trans prod_lepoll_self eqpoll_imp_lepoll
                 prod_commute_eqpoll)

lemma nat_lepoll_lemma:
     "\<lbrakk>0 \<notin> A; B \<in> A\<rbrakk> \<Longrightarrow> nat \<lesssim> ((nat \<rightarrow> \<Union>(A)) \<times> B) \<times> nat"
by (blast dest: Sigma_fun_space_not0 intro: snd_lepoll_SigmaI)

lemma AC9_AC1_lemma1:
     "\<lbrakk>0\<notin>A;  A\<noteq>0;
         C = {((nat->\<Union>(A))*B)*nat. B \<in> A}  \<union>
             {cons(0,((nat->\<Union>(A))*B)*nat). B \<in> A};
         B1 \<in> C;  B2 \<in> C\<rbrakk>
      \<Longrightarrow> B1 \<approx> B2"
by (blast intro!: nat_lepoll_lemma Sigma_fun_space_eqpoll
                     nat_cons_eqpoll [THEN eqpoll_trans]
                     prod_eqpoll_cong [OF _ eqpoll_refl]
             intro: eqpoll_trans eqpoll_sym )

lemma AC9_AC1_lemma2:
     "\<forall>B1 \<in> {(F*B)*N. B \<in> A} \<union> {cons(0,(F*B)*N). B \<in> A}.
      \<forall>B2 \<in> {(F*B)*N. B \<in> A} \<union> {cons(0,(F*B)*N). B \<in> A}.
        f`\<langle>B1,B2\<rangle> \<in> bij(B1, B2)
      \<Longrightarrow> (\<lambda>B \<in> A. snd(fst((f`<cons(0,(F*B)*N),(F*B)*N>)`0))) \<in> (\<Prod>X \<in> A. X)"
apply (intro lam_type snd_type fst_type)
apply (rule apply_type [OF _ consI1])
apply (fast intro!: fun_weaken_type bij_is_fun)
done

lemma AC9_AC1: "AC9 \<Longrightarrow> AC1"
  unfolding AC1_def AC9_def
apply (intro allI impI)
apply (erule allE)
apply (case_tac "A\<noteq>0")
apply (blast dest: AC9_AC1_lemma1 AC9_AC1_lemma2, force)
done

end


(* Author: R. Thiemann *)
section \<open>The Incremental Simplex Algorithm\<close>

text \<open>In this theory we specify operations which permit to incrementally
  add constraints. To this end, first an indexed list of potential constraints is used
  to construct the initial state, and then one can activate indices, extract solutions or unsat cores,
  do backtracking, etc.\<close>

theory Simplex_Incremental
  imports Simplex
begin

subsection \<open>Lowest Layer: Fixed Tableau and Incremental Atoms\<close>

text \<open>Interface\<close>

locale Incremental_Atom_Ops = fixes
  init_s :: "tableau \<Rightarrow> 's" and
  assert_s :: "('i,'a :: lrv) i_atom \<Rightarrow> 's \<Rightarrow> 'i list + 's" and
  check_s :: "'s \<Rightarrow> 'i list + 's" and
  solution_s :: "'s \<Rightarrow> (var, 'a) mapping" and
  checkpoint_s :: "'s \<Rightarrow> 'c" and
  backtrack_s :: "'c \<Rightarrow> 's \<Rightarrow> 's" and
  precond_s :: "tableau \<Rightarrow> bool" and
  invariant_s :: "tableau \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> 's \<Rightarrow> bool" and
  checked_s :: "tableau \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> 's \<Rightarrow> bool"
assumes
  assert_s_ok: "invariant_s t as s \<Longrightarrow> assert_s a s = Inr s' \<Longrightarrow>
    invariant_s t (insert a as) s'" and
  assert_s_unsat: "invariant_s t as s \<Longrightarrow> assert_s a s = Unsat I \<Longrightarrow>
    minimal_unsat_core_tabl_atoms (set I) t (insert a as)" and
  check_s_ok: "invariant_s t as s \<Longrightarrow> check_s s = Inr s' \<Longrightarrow>
    checked_s t as s'" and
  check_s_unsat: "invariant_s t as s \<Longrightarrow> check_s s = Unsat I \<Longrightarrow>
    minimal_unsat_core_tabl_atoms (set I) t as" and
  init_s: "precond_s t \<Longrightarrow> checked_s t {} (init_s t)" and
  solution_s: "checked_s t as s \<Longrightarrow> solution_s s = v \<Longrightarrow> \<langle>v\<rangle> \<Turnstile>\<^sub>t t \<and> \<langle>v\<rangle> \<Turnstile>\<^sub>a\<^sub>s Simplex.flat as" and
  backtrack_s: "checked_s t as s \<Longrightarrow> checkpoint_s s = c
    \<Longrightarrow> invariant_s t bs s' \<Longrightarrow> backtrack_s c s' = s'' \<Longrightarrow> as \<subseteq> bs \<Longrightarrow> invariant_s t as s''" and
  checked_invariant_s: "checked_s t as s \<Longrightarrow> invariant_s t as s"
begin

fun assert_all_s :: "('i,'a) i_atom list \<Rightarrow> 's \<Rightarrow> 'i list + 's" where
  "assert_all_s [] s = Inr s"
| "assert_all_s (a # as) s = (case assert_s a s of Unsat I \<Rightarrow> Unsat I
     | Inr s' \<Rightarrow> assert_all_s as s')"

lemma assert_all_s_ok: "invariant_s t as s \<Longrightarrow> assert_all_s bs s = Inr s' \<Longrightarrow>
    invariant_s t (set bs \<union> as) s'"
proof (induct bs arbitrary: s as)
  case (Cons b bs s as)
  from Cons(3) obtain s'' where ass: "assert_s b s = Inr s''" and rec: "assert_all_s bs s'' = Inr s'"
    by (auto split: sum.splits)
  from Cons(1)[OF assert_s_ok[OF Cons(2) ass] rec]
  show ?case by auto
qed auto

lemma assert_all_s_unsat: "invariant_s t as s \<Longrightarrow> assert_all_s bs s = Unsat I \<Longrightarrow>
   minimal_unsat_core_tabl_atoms (set I) t (as \<union> set bs)"
proof (induct bs arbitrary: s as)
  case (Cons b bs s as)
  show ?case
  proof (cases "assert_s b s")
    case unsat: (Inl J)
    with Cons have J: "J = I" by auto
    from assert_s_unsat[OF Cons(2) unsat] J
    have min: "minimal_unsat_core_tabl_atoms (set I) t (insert b as)" by auto
    show ?thesis
      by (rule minimal_unsat_core_tabl_atoms_mono[OF _ min], auto)
  next
    case (Inr s')
    from Cons(1)[OF assert_s_ok[OF Cons(2) Inr]] Cons(3) Inr show ?thesis by auto
  qed
qed simp

end

text \<open>Implementation of the interface via the Simplex operations init, check, and assert-bound.\<close>

locale Incremental_State_Ops_Simplex = AssertBoundNoLhs assert_bound + Init init + Check check
  for assert_bound :: "('i,'a::lrv) i_atom \<Rightarrow> ('i,'a) state \<Rightarrow> ('i,'a) state" and
    init :: "tableau \<Rightarrow> ('i,'a) state" and
    check :: "('i,'a) state \<Rightarrow> ('i,'a) state"
begin

definition invariant_s where
  "invariant_s t (as :: ('i,'a)i_atom set) s =
    (\<not> \<U> s \<and> \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s \<and>
     \<triangle> (\<T> s) \<and>
     \<nabla> s \<and>
     \<diamond> s \<and>
     (\<forall> v :: (var \<Rightarrow> 'a). v \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t t) \<and>
     index_valid as s \<and>
     Simplex.flat as \<doteq> \<B> s \<and>
     as \<Turnstile>\<^sub>i \<B>\<I> s)"

definition checked_s where
  "checked_s t as s = (invariant_s t as s \<and> \<Turnstile> s)"

definition assert_s where "assert_s a s = (let s' = assert_bound a s in
  if \<U> s' then Inl (the (\<U>\<^sub>c s')) else Inr s')"

definition check_s where "check_s s = (let s' = check s in
  if \<U> s' then Inl (the (\<U>\<^sub>c s')) else Inr s')"

definition checkpoint_s where "checkpoint_s s = \<B>\<^sub>i s"

fun backtrack_s where "backtrack_s (bl, bu) (State t bl_old bu_old v u uc) = State t bl bu v u uc"

lemma invariant_sD: assumes "invariant_s t as s"
  shows "\<not> \<U> s" "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s" "\<triangle> (\<T> s)" "\<nabla> s" "\<diamond> s"
    "Simplex.flat as \<doteq> \<B> s" "as \<Turnstile>\<^sub>i \<B>\<I> s" "index_valid as s"
    "(\<forall> v :: (var \<Rightarrow> 'a). v \<Turnstile>\<^sub>t \<T> s \<longleftrightarrow> v \<Turnstile>\<^sub>t t)"
  using assms unfolding invariant_s_def by auto

lemma minimal_unsat_state_core_translation: assumes
  unsat: "minimal_unsat_state_core (s :: ('i,'a::lrv)state)" and
  tabl: "\<forall>(v :: 'a valuation). v \<Turnstile>\<^sub>t \<T> s = v \<Turnstile>\<^sub>t t" and
  index: "index_valid as s" and
  imp: "as \<Turnstile>\<^sub>i \<B>\<I> s" and
  I: "I = the (\<U>\<^sub>c s)"
shows "minimal_unsat_core_tabl_atoms (set I) t as"
  unfolding minimal_unsat_core_tabl_atoms_def
proof (intro conjI impI notI allI; (elim exE conjE)?)
  from unsat[unfolded minimal_unsat_state_core_def]
  have unsat: "unsat_state_core s"
    and minimal: "distinct_indices_state s \<Longrightarrow> subsets_sat_core s"
    by auto
  from unsat[unfolded unsat_state_core_def I[symmetric]]
  have Is: "set I \<subseteq> indices_state s" and unsat: "(\<nexists>v. (set I, v) \<Turnstile>\<^sub>i\<^sub>s s)" by auto
  from Is index show "set I \<subseteq> fst ` as"
    using index_valid_indices_state by blast
  {
    fix v
    assume t: "v \<Turnstile>\<^sub>t t" and as: "(set I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s as"
    from t tabl have t: "v \<Turnstile>\<^sub>t \<T> s" by auto
    then have "(set I, v) \<Turnstile>\<^sub>i\<^sub>s s" using as imp
      using atoms_imply_bounds_index.simps satisfies_state_index.simps by blast
    with unsat show False by blast
  }
  {
    fix J
    assume dist: "distinct_indices_atoms as"
      and J: "J \<subset> set I"
    from J Is have J': "J \<subseteq> indices_state s" by auto
    from dist index have "distinct_indices_state s" by (metis index_valid_distinct_indices)
    with minimal have "subsets_sat_core s" .
    from this[unfolded subsets_sat_core_def I[symmetric], rule_format, OF J]
    obtain v where "(J, v) \<Turnstile>\<^sub>i\<^sub>s\<^sub>e s" by blast
    from satisfying_state_valuation_to_atom_tabl[OF J' this index dist] tabl
    show "\<exists>v. v \<Turnstile>\<^sub>t t \<and> (J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>e\<^sub>s as" by blast
  }
qed

lemma incremental_atom_ops: "Incremental_Atom_Ops
  init assert_s check_s \<V> checkpoint_s backtrack_s \<triangle> invariant_s checked_s"
proof (unfold_locales, goal_cases)
  case (1 t as s a s') (* assert ok *)
  from 1(2)[unfolded assert_s_def Let_def]
  have U: "\<not> \<U> (assert_bound a s)" and s': "s' = assert_bound a s" by (auto split: if_splits)
  note * = invariant_sD[OF 1(1)]
  from assert_bound_nolhs_tableau_id[OF *(1-5)]
  have T: "\<T> s' = \<T> s" unfolding s' by auto
  from *(3,9)
  have "\<triangle> (\<T> s')" "\<forall> v :: var \<Rightarrow> 'a. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t t" unfolding T by blast+
  moreover from assert_bound_nolhs_sat[OF *(1-5) U]
  have " \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'" "\<diamond> s'" unfolding s' by auto
  moreover from assert_bound_nolhs_atoms_equiv_bounds[OF *(1-6), of a]
  have "Simplex.flat (insert a as) \<doteq> \<B> s'" unfolding s' by auto
  moreover from assert_bound_nolhs_atoms_imply_bounds_index[OF *(1-5,7)]
  have "insert a as \<Turnstile>\<^sub>i \<B>\<I> s'" unfolding s' .
  moreover from assert_bound_nolhs_tableau_valuated[OF *(1-5)]
  have "\<nabla> s'" unfolding s' .
  moreover from assert_bound_nolhs_index_valid[OF *(1-5,8)]
  have "index_valid (insert a as) s'" unfolding s' by auto
  moreover from U s'
  have "\<not> \<U> s'" by auto
  ultimately show ?case unfolding invariant_s_def by auto
next
  case (2 t as s a I) (* assert unsat *)
  from 2(2)[unfolded assert_s_def Let_def]
  obtain s' where s': "s' = assert_bound a s" and U: "\<U> (assert_bound a s)"
    and I: "I = the (\<U>\<^sub>c s')"
    by (auto split: if_splits)
  note * = invariant_sD[OF 2(1)]
  from assert_bound_nolhs_tableau_id[OF *(1-5)]
  have T: "\<T> s' = \<T> s" unfolding s' by auto
  from *(3,9)
  have tabl: "\<forall> v :: var \<Rightarrow> 'a. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t t" unfolding T by blast+
  from assert_bound_nolhs_unsat[OF *(1-5,8) U] s'
  have unsat: "minimal_unsat_state_core s'" by auto
  from assert_bound_nolhs_index_valid[OF *(1-5,8)]
  have index: "index_valid (insert a as) s'" unfolding s' by auto
  from assert_bound_nolhs_atoms_imply_bounds_index[OF *(1-5,7)]
  have imp: "insert a as \<Turnstile>\<^sub>i \<B>\<I> s'" unfolding s' .
  from minimal_unsat_state_core_translation[OF unsat tabl index imp I]
  show ?case .
next
  case (3 t as s s') (* check ok *)
  from 3(2)[unfolded check_s_def Let_def]
  have U: "\<not> \<U> (check s)" and s': "s' = check s" by (auto split: if_splits)
  note * = invariant_sD[OF 3(1)]
  note ** = *(1,2,5,3,4)
  from check_tableau_equiv[OF **] *(9)
  have "\<forall>v :: _ \<Rightarrow> 'a. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t t" unfolding s' by auto
  moreover from check_tableau_index_valid[OF **] *(8)
  have "index_valid as s'" unfolding s' by auto
  moreover from check_tableau_normalized[OF **]
  have "\<triangle> (\<T> s')" unfolding s' .
  moreover from check_tableau_valuated[OF **]
  have "\<nabla> s'" unfolding s' .
  moreover from check_sat[OF ** U]
  have "\<Turnstile> s'" unfolding s'.
  moreover from satisfies_satisfies_no_lhs[OF this] satisfies_consistent[of s'] this
  have " \<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s'" "\<diamond> s'" by blast+
  moreover from check_bounds_id[OF **] *(6)
  have "Simplex.flat as \<doteq> \<B> s'" unfolding s' by (auto simp: boundsu_def boundsl_def)
  moreover from check_bounds_id[OF **] *(7)
  have "as \<Turnstile>\<^sub>i \<B>\<I> s'" unfolding s' by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
  moreover from U
  have "\<not> \<U> s'" unfolding s' .
  ultimately show ?case unfolding invariant_s_def checked_s_def by auto
next
  case (4 t as s I) (* check Unsat *)
  from 4(2)[unfolded check_s_def Let_def]
  obtain s' where s': "s' = check s" and U: "\<U> (check s)"
    and I: "I = the (\<U>\<^sub>c s')"
    by (auto split: if_splits)
  note * = invariant_sD[OF 4(1)]
  note ** = *(1,2,5,3,4)
  from check_unsat[OF ** U]
  have unsat: "minimal_unsat_state_core s'" unfolding s' by auto
  from check_tableau_equiv[OF **] *(9)
  have tabl: "\<forall>v :: _ \<Rightarrow> 'a. v \<Turnstile>\<^sub>t \<T> s' = v \<Turnstile>\<^sub>t t" unfolding s' by auto
  from check_tableau_index_valid[OF **] *(8)
  have index: "index_valid as s'" unfolding s' by auto
  from check_bounds_id[OF **] *(7)
  have imp: "as \<Turnstile>\<^sub>i \<B>\<I> s'" unfolding s' by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
  from minimal_unsat_state_core_translation[OF unsat tabl index imp I]
  show ?case .
next
  case *: (5 t) (* init *)
  show ?case unfolding checked_s_def invariant_s_def
    using
      init_tableau_normalized[OF *]
      init_index_valid[of _ t]
      init_atoms_imply_bounds_index[of t]
      init_satisfies[of t]
      init_atoms_equiv_bounds[of t]
      init_tableau_id[of t]
      init_unsat_flag[of t]
      init_tableau_valuated[of t]
      satisfies_consistent[of "init t"] satisfies_satisfies_no_lhs[of "init t"]
    by auto
next
  case (6 t as s v) (* solution *)
  then show ?case unfolding checked_s_def invariant_s_def
    by (meson atoms_equiv_bounds.simps curr_val_satisfies_state_def satisfies_state_def)
next
  case (7 t as s c bs s' s'') (* checkpoint and backtrack *)
  from 7(1)[unfolded checked_s_def]
  have inv_s: "invariant_s t as s" and s: "\<Turnstile> s" by auto
  from 7(2) have c: "c = \<B>\<^sub>i s" unfolding checkpoint_s_def by auto
  have s'': "\<T> s'' = \<T> s'" "\<V> s'' = \<V> s'" "\<B>\<^sub>i s'' = \<B>\<^sub>i s" "\<U> s'' = \<U> s'" "\<U>\<^sub>c s'' = \<U>\<^sub>c s'"
    unfolding 7(4)[symmetric] c
    by (atomize(full), cases s', auto)
  then have BI: "\<B> s'' = \<B> s" "\<I> s'' = \<I> s" by (auto simp: boundsu_def boundsl_def indexu_def indexl_def)
  note * = invariant_sD[OF inv_s]
  note ** = invariant_sD[OF 7(3)]
  from **(1)
  have "\<not> \<U> s''" unfolding s'' .
  moreover from **(3)
  have "\<triangle> (\<T> s'')" unfolding s'' .
  moreover from **(4)
  have "\<nabla> s''" unfolding tableau_valuated_def s'' .
  moreover from **(9)
  have "\<forall>v :: _ \<Rightarrow> 'a. v \<Turnstile>\<^sub>t \<T> s'' = v \<Turnstile>\<^sub>t t" unfolding s'' .
  moreover from *(6)
  have "Simplex.flat as \<doteq> \<B> s''" unfolding BI .
  moreover from *(7)
  have "as \<Turnstile>\<^sub>i \<B>\<I> s''" unfolding BI .
  moreover from *(8)
  have "index_valid as s''" unfolding index_valid_def using s'' by auto
  moreover from **(4)
  have "\<nabla> s''" unfolding tableau_valuated_def s'' .
  moreover from satisfies_consistent[of s] s
  have "\<diamond> s''" unfolding bounds_consistent_def using BI by auto
  moreover
  from 7(5) *(6) **(6)
  have vB: "v \<Turnstile>\<^sub>b \<B> s' \<Longrightarrow> v \<Turnstile>\<^sub>b \<B> s''" for v
    unfolding atoms_equiv_bounds.simps satisfies_atom_set_def BI
    by force
  from **(2)
  have t: "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>t \<T> s'" and b: "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>b \<B> s' \<parallel> - lvars (\<T> s')"
    unfolding curr_val_satisfies_no_lhs_def by auto
  let ?v = "\<lambda> x. if x \<in> lvars (\<T> s') then case \<B>\<^sub>l s' x of None \<Rightarrow> the (\<B>\<^sub>u s' x) | Some b \<Rightarrow> b else \<langle>\<V> s'\<rangle> x"
  have "?v \<Turnstile>\<^sub>b \<B> s'" unfolding satisfies_bounds.simps
  proof (intro allI)
    fix x :: var
    show "in_bounds x ?v (\<B> s')"
    proof (cases "x \<in> lvars (\<T> s')")
      case True
      with **(5)[unfolded bounds_consistent_def, rule_format, of x]
      show ?thesis by (cases "\<B>\<^sub>l s' x"; cases "\<B>\<^sub>u s' x", auto simp: bound_compare_defs)
    next
      case False
      with b
      show ?thesis unfolding satisfies_bounds_set.simps by auto
    qed
  qed
  from vB[OF this] have v: "?v \<Turnstile>\<^sub>b \<B> s''" .
  have "\<langle>\<V> s'\<rangle> \<Turnstile>\<^sub>b \<B> s'' \<parallel> - lvars (\<T> s')" unfolding satisfies_bounds_set.simps
  proof clarify
    fix x
    assume "x \<notin> lvars (\<T> s')"
    with v[unfolded satisfies_bounds.simps, rule_format, of x]
    show "in_bounds x \<langle>\<V> s'\<rangle> (\<B> s'')" by auto
  qed
  with t have "\<Turnstile>\<^sub>n\<^sub>o\<^sub>l\<^sub>h\<^sub>s s''" unfolding curr_val_satisfies_no_lhs_def s''
    by auto
  ultimately show ?case unfolding invariant_s_def by blast
qed (auto simp: checked_s_def)

end

subsection \<open>Intermediate Layer: Incremental Non-Strict Constraints\<close>

text \<open>Interface\<close>

locale Incremental_NS_Constraint_Ops = fixes
  init_nsc :: "('i,'a :: lrv) i_ns_constraint list \<Rightarrow> 's" and
  assert_nsc :: "'i \<Rightarrow> 's \<Rightarrow> 'i list + 's" and
  check_nsc :: "'s \<Rightarrow> 'i list + 's" and
  solution_nsc :: "'s \<Rightarrow> (var, 'a) mapping" and
  checkpoint_nsc :: "'s \<Rightarrow> 'c" and
  backtrack_nsc :: "'c \<Rightarrow> 's \<Rightarrow> 's" and
  invariant_nsc :: "('i,'a) i_ns_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool" and
  checked_nsc :: "('i,'a) i_ns_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool"
assumes
  assert_nsc_ok: "invariant_nsc nsc J s \<Longrightarrow> assert_nsc j s = Inr s' \<Longrightarrow>
    invariant_nsc nsc (insert j J) s'" and
  assert_nsc_unsat: "invariant_nsc nsc J s \<Longrightarrow> assert_nsc j s = Unsat I \<Longrightarrow>
    set I \<subseteq> insert j J \<and> minimal_unsat_core_ns (set I) (set nsc)" and
  check_nsc_ok: "invariant_nsc nsc J s \<Longrightarrow> check_nsc s = Inr s' \<Longrightarrow>
    checked_nsc nsc J s'" and
  check_nsc_unsat: "invariant_nsc nsc J s \<Longrightarrow> check_nsc s = Unsat I \<Longrightarrow>
    set I \<subseteq> J \<and> minimal_unsat_core_ns (set I) (set nsc)" and
  init_nsc: "checked_nsc nsc {} (init_nsc nsc)" and
  solution_nsc: "checked_nsc nsc J s \<Longrightarrow> solution_nsc s = v \<Longrightarrow> (J, \<langle>v\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s set nsc" and
  backtrack_nsc: "checked_nsc nsc J s \<Longrightarrow> checkpoint_nsc s = c
    \<Longrightarrow> invariant_nsc nsc K s' \<Longrightarrow> backtrack_nsc c s' = s'' \<Longrightarrow> J \<subseteq> K \<Longrightarrow> invariant_nsc nsc J s''" and
  checked_invariant_nsc: "checked_nsc nsc J s \<Longrightarrow> invariant_nsc nsc J s"

text \<open>Implementation via the Simplex operation preprocess and the incremental operations for atoms.\<close>

fun create_map :: "('i \<times> 'a)list \<Rightarrow> ('i, ('i \<times> 'a) list)mapping" where
  "create_map [] = Mapping.empty"
| "create_map ((i,a) # xs) = (let m = create_map xs in
     case Mapping.lookup m i of
       None \<Rightarrow> Mapping.update i [(i,a)] m
     | Some ias \<Rightarrow> Mapping.update i ((i,a) # ias) m)"

definition list_map_to_fun :: "('i, ('i \<times> 'a) list)mapping \<Rightarrow> 'i \<Rightarrow> ('i \<times> 'a) list" where
  "list_map_to_fun m i = (case Mapping.lookup m i of None \<Rightarrow> [] | Some ias \<Rightarrow> ias)"

lemma list_map_to_fun_create_map: "set (list_map_to_fun (create_map ias) i) = set ias \<inter> {i} \<times> UNIV"
proof (induct ias)
  case Nil
  show ?case unfolding list_map_to_fun_def by auto
next
  case (Cons ja ias)
  obtain j a where ja: "ja = (j,a)" by force
  show ?case
  proof (cases "j = i")
    case False
    then have id: "list_map_to_fun (create_map (ja # ias)) i = list_map_to_fun (create_map ias) i"
      unfolding ja list_map_to_fun_def
      by (auto simp: Let_def split: option.splits)
    show ?thesis unfolding id Cons unfolding ja using False by auto
  next
    case True
    with ja have ja: "ja = (i,a)" by auto
    have id: "list_map_to_fun (create_map (ja # ias)) i = ja # list_map_to_fun (create_map ias) i"
      unfolding ja list_map_to_fun_def
      by (auto simp: Let_def split: option.splits)
    show ?thesis unfolding id using Cons unfolding ja by auto
  qed
qed

fun sum_wrap :: "('c \<Rightarrow> 's \<Rightarrow> 'i list + 's)
  \<Rightarrow> 'c \<times> 's \<Rightarrow> 'i list + ('c \<times> 's)" where
  "sum_wrap f (asi,s) = (case f asi s of Unsat I \<Rightarrow> Unsat I | Inr s' \<Rightarrow> Inr (asi,s'))"

definition check_nsc where "check_nsc check_s = sum_wrap (\<lambda> asitv. check_s)"

definition assert_nsc where "assert_nsc assert_all_s i = (\<lambda> ((asi,tv,ui),s).
  if i \<in> set ui then Unsat [i] else
  case assert_all_s (list_map_to_fun asi i) s of Unsat I \<Rightarrow> Unsat I | Inr s' \<Rightarrow> Inr ((asi,tv,ui),s'))"
fun checkpoint_nsc where "checkpoint_nsc checkpoint_s (asi_tv_ui,s) = checkpoint_s s"
fun backtrack_nsc where "backtrack_nsc backtrack_s c (asi_tv_ui,s) = (asi_tv_ui, backtrack_s c s)"
fun solution_nsc where "solution_nsc solution_s ((asi,tv,ui),s) = tv (solution_s s)"

locale Incremental_Atom_Ops_For_NS_Constraint_Ops =
  Incremental_Atom_Ops init_s assert_s check_s solution_s checkpoint_s backtrack_s \<triangle>
  invariant_s checked_s
  + Preprocess preprocess
  for
    init_s :: "tableau \<Rightarrow> 's" and
    assert_s :: "('i :: linorder,'a :: lrv) i_atom \<Rightarrow> 's \<Rightarrow> 'i list + 's" and
    check_s :: "'s \<Rightarrow> 'i list + 's" and
    solution_s :: "'s \<Rightarrow> (var, 'a) mapping" and
    checkpoint_s :: "'s \<Rightarrow> 'c" and
    backtrack_s :: "'c \<Rightarrow> 's \<Rightarrow> 's" and
    invariant_s :: "tableau \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> 's \<Rightarrow> bool" and
    checked_s :: "tableau \<Rightarrow> ('i,'a) i_atom set \<Rightarrow> 's \<Rightarrow> bool" and
    preprocess :: "('i,'a) i_ns_constraint list \<Rightarrow> tableau \<times> ('i,'a) i_atom list \<times> ((var,'a)mapping \<Rightarrow> (var,'a)mapping) \<times> 'i list"
begin

definition "init_nsc nsc = (case preprocess nsc of (t,as,trans_v,ui) \<Rightarrow>
   ((create_map as, trans_v, remdups ui), init_s t))"

fun invariant_as_asi where "invariant_as_asi as asi tc tc' ui ui' = (tc = tc' \<and> set ui = set ui' \<and>
    (\<forall> i. set (list_map_to_fun asi i) = (as \<inter> ({i} \<times> UNIV))))"

fun invariant_nsc where
  "invariant_nsc nsc J ((asi,tv,ui),s) = (case preprocess nsc of (t,as,tv',ui') \<Rightarrow> invariant_as_asi (set as) asi tv tv' ui ui' \<and>
     invariant_s t (set as \<inter> (J \<times> UNIV)) s \<and> J \<inter> set ui = {})"

fun checked_nsc where
  "checked_nsc nsc J ((asi,tv,ui),s) = (case preprocess nsc of (t,as,tv',ui') \<Rightarrow> invariant_as_asi (set as) asi tv tv' ui ui' \<and>
     checked_s t (set as \<inter> (J \<times> UNIV)) s \<and> J \<inter> set ui = {})"

lemma i_satisfies_atom_set_inter_right: "((I, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s (ats \<inter> (J \<times> UNIV))) \<longleftrightarrow> ((I \<inter> J, v) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s ats)"
  unfolding i_satisfies_atom_set.simps
  by (rule arg_cong[of _ _ "\<lambda> x. v \<Turnstile>\<^sub>a\<^sub>s x"], auto)

lemma ns_constraints_ops: "Incremental_NS_Constraint_Ops init_nsc (assert_nsc assert_all_s)
  (check_nsc check_s) (solution_nsc solution_s) (checkpoint_nsc checkpoint_s) (backtrack_nsc backtrack_s)
  invariant_nsc checked_nsc"
proof (unfold_locales, goal_cases)
  case (1 nsc J S j S') (* assert ok *)
  obtain asi tv s ui where S: "S = ((asi,tv,ui),s)" by (cases S, auto)
  obtain t as tv' ui' where prep[simp]: "preprocess nsc = (t, as, tv', ui')" by (cases "preprocess nsc")
  note pre = 1[unfolded S assert_nsc_def]
  from pre(2) obtain s' where
    ok: "assert_all_s (list_map_to_fun asi j) s = Inr s'" and S': "S' = ((asi,tv,ui),s')" and j: "j \<notin> set ui"
    by (auto split: sum.splits if_splits)
  from pre(1)[simplified]
  have inv: "invariant_s t (set as \<inter> J \<times> UNIV) s"
    and asi: "set (list_map_to_fun asi j) = set as \<inter> {j} \<times> UNIV" "invariant_as_asi (set as) asi tv tv' ui ui'" "J \<inter> set ui = {}" by auto
  from assert_all_s_ok[OF inv ok, unfolded asi] asi(2-) j
  show ?case unfolding invariant_nsc.simps S' prep split
    by (metis Int_insert_left Sigma_Un_distrib1 inf_sup_distrib1 insert_is_Un)
next
  case (2 nsc J S j I) (* assert unsat *)
  obtain asi s tv ui where S: "S = ((asi,tv,ui),s)" by (cases S, auto)
  obtain t as tv' ui' where prep[simp]: "preprocess nsc = (t, as, tv', ui')" by (cases "preprocess nsc")
  note pre = 2[unfolded S assert_nsc_def split]
  show ?case
  proof (cases "j \<in> set ui")
    case False
    with pre(2) have unsat: "assert_all_s (list_map_to_fun asi j) s = Unsat I"
      by (auto split: sum.splits)
    from pre(1)
    have inv: "invariant_s t (set as \<inter> J \<times> UNIV) s"
      and asi: "set (list_map_to_fun asi j) = set as \<inter> {j} \<times> UNIV" by auto
    from assert_all_s_unsat[OF inv unsat, unfolded asi]
    have "minimal_unsat_core_tabl_atoms (set I) t (set as \<inter> J \<times> UNIV \<union> set as \<inter> {j} \<times> UNIV)" .
    also have "set as \<inter> J \<times> UNIV \<union> set as \<inter> {j} \<times> UNIV = set as \<inter> insert j J \<times> UNIV" by blast
    finally have unsat: "minimal_unsat_core_tabl_atoms (set I) t (set as \<inter> insert j J \<times> UNIV)" .
    hence I: "set I \<subseteq> insert j J" unfolding minimal_unsat_core_tabl_atoms_def by force
    with False pre have empty: "set I \<inter> set ui' = {}" by auto
    have "minimal_unsat_core_tabl_atoms (set I) t (set as)"
      by (rule minimal_unsat_core_tabl_atoms_mono[OF _ unsat], auto)
    from preprocess_minimal_unsat_core[OF prep this empty]
    have "minimal_unsat_core_ns (set I) (set nsc)" .
    then show ?thesis using I by blast
  next
    case True
    with pre(2) have I: "I = [j]" by auto
    from pre(1)[unfolded invariant_nsc.simps prep split invariant_as_asi.simps]
    have "set ui = set ui'" by simp
    with True have j: "j \<in> set ui'" by auto
    from preprocess_unsat_index[OF prep j]
    show ?thesis unfolding I by auto
  qed
next
  case (3 nsc J S S') (* check ok *)
  then show ?case using check_s_ok unfolding check_nsc_def
    by (cases S, auto split: sum.splits)
next
  case (4 nsc J S I) (* check unsat *)
  obtain asi s tv ui where S: "S = ((asi,tv,ui),s)" by (cases S, auto)
  obtain t as tv' ui' where prep[simp]: "preprocess nsc = (t, as, tv', ui')" by (cases "preprocess nsc")
  note pre = 4[unfolded S check_nsc_def, simplified]
  from pre have
    unsat: "check_s s = Unsat I"  and
    inv: "invariant_s t (set as \<inter> J \<times> UNIV) s"
    by (auto split: sum.splits)
  from check_s_unsat[OF inv unsat]
  have unsat: "minimal_unsat_core_tabl_atoms (set I) t (set as \<inter> J \<times> UNIV)" .
  hence I: "set I \<subseteq> J" unfolding minimal_unsat_core_tabl_atoms_def by force
  with pre have empty: "set I \<inter> set ui' = {}" by auto
  have "minimal_unsat_core_tabl_atoms (set I) t (set as)"
    by (rule minimal_unsat_core_tabl_atoms_mono[OF _ unsat], auto)
  from preprocess_minimal_unsat_core[OF prep this empty]
  have "minimal_unsat_core_ns (set I) (set nsc)" .
  then show ?case using I by blast
next
  case (5 nsc) (* init *)
  obtain t as tv' ui' where prep[simp]: "preprocess nsc = (t, as, tv', ui')" by (cases "preprocess nsc")
  show ?case unfolding init_nsc_def
    using init_s preprocess_tableau_normalized[OF prep]
    by (auto simp: list_map_to_fun_create_map)
next
  case (6 nsc J S v) (* solution *)
  obtain asi s tv ui where S: "S = ((asi,tv,ui),s)" by (cases S, auto)
  obtain t as tv' ui' where prep[simp]: "preprocess nsc = (t, as, tv', ui')" by (cases "preprocess nsc")
  have "(J,\<langle>solution_s s\<rangle>) \<Turnstile>\<^sub>i\<^sub>a\<^sub>s set as" "\<langle>solution_s s\<rangle> \<Turnstile>\<^sub>t t"
    using 6 S solution_s[of t _ s] by auto
  from i_preprocess_sat[OF prep _ this]
  show ?case using 6 S by auto
next
  case (7 nsc J S c K S' S'') (* backtrack *)
  obtain t as tvp uip where prep[simp]: "preprocess nsc = (t, as, tvp, uip)" by (cases "preprocess nsc")
  obtain asi s tv ui where S: "S = ((asi,tv,ui),s)" by (cases S, auto)
  obtain asi' s' tv' ui' where S': "S' = ((asi',tv',ui'),s')" by (cases S', auto)
  obtain asi'' s'' tv'' ui'' where S'': "S'' = ((asi'',tv'',ui''),s'')" by (cases S'', auto)
  from backtrack_s[of t _ s c _ s' s'']
  show ?case using 7 S S' S'' by auto
next
  case (8 nsc J S)
  then show ?case using checked_invariant_s by (cases S, auto)
qed

end

subsection \<open>Highest Layer: Incremental Constraints\<close>

text \<open>Interface\<close>

locale Incremental_Simplex_Ops = fixes
  init_cs :: "'i i_constraint list \<Rightarrow> 's" and
  assert_cs :: "'i \<Rightarrow> 's \<Rightarrow> 'i list + 's" and
  check_cs :: "'s \<Rightarrow> 'i list + 's" and
  solution_cs :: "'s \<Rightarrow> rat valuation" and
  checkpoint_cs :: "'s \<Rightarrow> 'c" and
  backtrack_cs :: "'c \<Rightarrow> 's \<Rightarrow> 's" and
  invariant_cs :: "'i i_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool" and
  checked_cs :: "'i i_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool"
assumes
  assert_cs_ok: "invariant_cs cs J s \<Longrightarrow> assert_cs j s = Inr s' \<Longrightarrow>
    invariant_cs cs (insert j J) s'" and
  assert_cs_unsat: "invariant_cs cs J s \<Longrightarrow> assert_cs j s = Unsat I \<Longrightarrow>
    set I \<subseteq> insert j J \<and> minimal_unsat_core (set I) cs" and
  check_cs_ok: "invariant_cs cs J s \<Longrightarrow> check_cs s = Inr s' \<Longrightarrow>
    checked_cs cs J s'" and
  check_cs_unsat: "invariant_cs cs J s \<Longrightarrow> check_cs s = Unsat I \<Longrightarrow>
    set I \<subseteq> J \<and> minimal_unsat_core (set I) cs" and
  init_cs: "checked_cs cs {} (init_cs cs)" and
  solution_cs: "checked_cs cs J s \<Longrightarrow> solution_cs s = v \<Longrightarrow> (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs" and
  backtrack_cs: "checked_cs cs J s \<Longrightarrow> checkpoint_cs s = c
    \<Longrightarrow> invariant_cs cs K s' \<Longrightarrow> backtrack_cs c s' = s'' \<Longrightarrow> J \<subseteq> K \<Longrightarrow> invariant_cs cs J s''" and
  checked_invariant_cs: "checked_cs cs J s \<Longrightarrow> invariant_cs cs J s"

text \<open>Implementation via the Simplex-operation To-Ns and the Incremental Operations for Non-Strict Constraints\<close>

fun assert_cs where "assert_cs ass i (cs,s) = (case ass i s of
    Unsat I \<Rightarrow> Unsat I
  | Inr s' \<Rightarrow> Inr (cs, s'))"

definition "init_cs init tons cs = (let tons_cs = tons cs in (map snd (tons_cs), init tons_cs))"

definition "check_cs check s = sum_wrap (\<lambda> cs. check) s"
fun checkpoint_cs where "checkpoint_cs checkp (cs,s) = (checkp s)"
fun backtrack_cs where "backtrack_cs backt c (cs,s) = (cs, backt c s)"
fun solution_cs where "solution_cs sol from (cs,s) = (\<langle>from (sol s) cs\<rangle>)"

locale Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex =
  Incremental_NS_Constraint_Ops init_nsc assert_nsc check_nsc solution_nsc checkpoint_nsc backtrack_nsc
  invariant_nsc checked_nsc + To_ns to_ns from_ns
  for
    init_nsc :: "('i,'a :: lrv) i_ns_constraint list \<Rightarrow> 's" and
    assert_nsc :: "'i \<Rightarrow> 's \<Rightarrow> 'i list + 's" and
    check_nsc :: "'s \<Rightarrow> 'i list + 's" and
    solution_nsc :: "'s \<Rightarrow> (var, 'a) mapping" and
    checkpoint_nsc :: "'s \<Rightarrow> 'c" and
    backtrack_nsc :: "'c \<Rightarrow> 's \<Rightarrow> 's" and
    invariant_nsc :: "('i,'a) i_ns_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool" and
    checked_nsc :: "('i,'a) i_ns_constraint list \<Rightarrow> 'i set \<Rightarrow> 's \<Rightarrow> bool" and
    to_ns :: "'i i_constraint list \<Rightarrow> ('i,'a) i_ns_constraint list" and
    from_ns :: "(var, 'a) mapping \<Rightarrow> 'a ns_constraint list \<Rightarrow> (var, rat) mapping"
begin

fun invariant_cs where
  "invariant_cs cs J (ds,s) = (ds = map snd (to_ns cs) \<and> invariant_nsc (to_ns cs) J s)"
fun checked_cs where
  "checked_cs cs J (ds,s) = (ds = map snd (to_ns cs) \<and> checked_nsc (to_ns cs) J s)"

sublocale Incremental_Simplex_Ops "init_cs init_nsc to_ns" "assert_cs assert_nsc"
  "check_cs check_nsc" "solution_cs solution_nsc from_ns" "checkpoint_cs checkpoint_nsc" "backtrack_cs backtrack_nsc"
  invariant_cs checked_cs
proof (unfold_locales, goal_cases)
  case (1 cs J S j S') (* assert ok *)
  then obtain s where S: "S = (map snd (to_ns cs),s)" by (cases S, auto)
  note pre = 1[unfolded S assert_cs.simps]
  from pre(2) obtain s' where
    ok: "assert_nsc j s = Inr s'" and S': "S' = (map snd (to_ns cs),s')"
    by (auto split: sum.splits)
  from pre(1)
  have inv: "invariant_nsc (to_ns cs) J s" by simp
  from assert_nsc_ok[OF inv ok]
  show ?case unfolding invariant_cs.simps S' split by auto
next
  case (2 cs J S j I) (* assert unsat *)
  then obtain s where S: "S = (map snd (to_ns cs), s)" by (cases S, auto)
  note pre = 2[unfolded S assert_cs.simps]
  from pre(2) have unsat: "assert_nsc j s = Unsat I"
    by (auto split: sum.splits)
  from pre(1) have inv: "invariant_nsc (to_ns cs) J s" by auto
  from assert_nsc_unsat[OF inv unsat]
  have "set I \<subseteq> insert j J" "minimal_unsat_core_ns (set I) (set (to_ns cs))"
    by auto
  from to_ns_unsat[OF this(2)] this(1)
  show ?case by blast
next
  case (3 cs J S S') (* check ok *)
  then show ?case using check_nsc_ok unfolding check_cs_def
    by (cases S, auto split: sum.splits)
next
  case (4 cs J S I) (* check unsat *)
  then obtain s where S: "S = (map snd (to_ns cs),s)" by (cases S, auto)
  note pre = 4[unfolded S check_cs_def]
  from pre(2) have unsat: "check_nsc s = Unsat I"
    by (auto split: sum.splits)
  from pre(1) have inv: "invariant_nsc (to_ns cs) J s" by auto
  from check_nsc_unsat[OF inv unsat]
  have "set I \<subseteq> J" "minimal_unsat_core_ns (set I) (set (to_ns cs))"
    unfolding minimal_unsat_core_ns_def by auto
  from to_ns_unsat[OF this(2)] this(1)
  show ?case by blast
next
  case (5 cs) (* init *)
  show ?case unfolding init_cs_def Let_def using init_nsc by auto
next
  case (6 cs J S v) (* solution *)
  then obtain s where S: "S = (map snd (to_ns cs),s)" by (cases S, auto)
  obtain w where w: "solution_nsc s = w" by auto
  note pre = 6[unfolded S solution_cs.simps w Let_def]
  from pre have
    inv: "checked_nsc (to_ns cs) J s" and
    v: "v = \<langle>from_ns w (map snd (to_ns cs))\<rangle>" by auto
  from solution_nsc[OF inv w] have w: "(J, \<langle>w\<rangle>) \<Turnstile>\<^sub>i\<^sub>n\<^sub>s\<^sub>s  set (to_ns cs)" .
  from i_to_ns_sat[OF w]
  show ?case unfolding v .
next
  case (7 cs J S c K S' S'') (* backtrack *)
  then show ?case using backtrack_nsc[of "to_ns cs" J]
    by (cases S, cases S', cases S'', auto)
next
  case (8 cs J S)
  then show ?case using checked_invariant_nsc by (cases S, auto)
qed

end

subsection \<open>Concrete Implementation\<close>

subsubsection \<open>Connecting all the locales\<close>

definition "assert_s = Incremental_State_Ops_Simplex.assert_s assert_bound_code"
definition "check_s = Incremental_State_Ops_Simplex.check_s check_code"
definition "checkpoint_s = Incremental_State_Ops_Simplex.checkpoint_s"
definition "backtrack_s = Incremental_State_Ops_Simplex.backtrack_s"
definition "invariant_s = Incremental_State_Ops_Simplex.invariant_s"
definition "checked_s = Incremental_State_Ops_Simplex.checked_s"

global_interpretation Incremental_State_Ops_Simplex_Default:
  Incremental_State_Ops_Simplex assert_bound_code init_state check_code
  rewrites
    "Incremental_State_Ops_Simplex.assert_s assert_bound_code = assert_s" and
    "Incremental_State_Ops_Simplex.check_s check_code = check_s" and
    "Incremental_State_Ops_Simplex.backtrack_s = backtrack_s" and
    "Incremental_State_Ops_Simplex.checkpoint_s = checkpoint_s" and
    "Incremental_State_Ops_Simplex.invariant_s = invariant_s" and
    "Incremental_State_Ops_Simplex.checked_s = checked_s"
  by (unfold_locales, auto simp:
      assert_s_def
      check_s_def
      checkpoint_s_def
      backtrack_s_def
      checked_s_def
      invariant_s_def)

definition "assert_all_s = Incremental_Atom_Ops.assert_all_s assert_s"

global_interpretation Incremental_Atom_Ops_Default:
  Incremental_Atom_Ops init_state assert_s check_s \<V> checkpoint_s backtrack_s \<triangle> invariant_s checked_s
  rewrites "Incremental_Atom_Ops.assert_all_s assert_s = assert_all_s"
  using Incremental_State_Ops_Simplex_Default.incremental_atom_ops
  by (auto simp: assert_all_s_def)

definition "init_nsc_code = (Incremental_Atom_Ops_For_NS_Constraint_Ops.init_nsc init_state preprocess :: _ \<Rightarrow> (('a :: linorder, ('a \<times> QDelta atom) list) mapping \<times> _) \<times> ('a, QDelta) state)"
definition "assert_nsc_code = assert_nsc assert_all_s"
definition "check_nsc_code = check_nsc check_s"
definition "checkpoint_nsc_code = checkpoint_nsc checkpoint_s"
definition "solution_nsc_code = solution_nsc \<V>"
definition "backtrack_nsc_code = backtrack_nsc backtrack_s"
definition "invariant_nsc = Incremental_Atom_Ops_For_NS_Constraint_Ops.invariant_nsc invariant_s preprocess"
definition "checked_nsc = Incremental_Atom_Ops_For_NS_Constraint_Ops.checked_nsc checked_s preprocess"

global_interpretation Incremental_Atom_Ops_For_NS_Constraint_Ops_Default:
  Incremental_Atom_Ops_For_NS_Constraint_Ops init_state assert_s check_s \<V>
  checkpoint_s backtrack_s invariant_s checked_s preprocess
  rewrites
    "Incremental_Atom_Ops_For_NS_Constraint_Ops.init_nsc init_state preprocess = init_nsc_code" and
    "check_nsc check_s = check_nsc_code" and
    "checkpoint_nsc checkpoint_s = checkpoint_nsc_code" and
    "solution_nsc \<V> = solution_nsc_code" and
    "backtrack_nsc backtrack_s = backtrack_nsc_code" and
    "assert_nsc assert_all_s = assert_nsc_code" and
    "Incremental_Atom_Ops_For_NS_Constraint_Ops.invariant_nsc invariant_s preprocess = invariant_nsc" and
    "Incremental_Atom_Ops_For_NS_Constraint_Ops.checked_nsc checked_s preprocess = checked_nsc" and
    "Incremental_Atom_Ops.assert_all_s assert_s = assert_all_s"
  by (unfold_locales, auto simp:
      init_nsc_code_def
      assert_nsc_code_def
      check_nsc_code_def
      checkpoint_nsc_code_def
      solution_nsc_code_def
      backtrack_nsc_code_def
      invariant_nsc_def
      checked_nsc_def
      assert_all_s_def
      )

type_synonym 'i simplex_state' = "QDelta ns_constraint list
  \<times> (('i, ('i \<times> QDelta atom) list) mapping \<times> ((var,QDelta)mapping \<Rightarrow> (var,QDelta)mapping) \<times> 'i list)
  \<times> ('i, QDelta) state"

definition "init_simplex' = (init_cs init_nsc_code to_ns :: 'i :: linorder i_constraint list \<Rightarrow> 'i simplex_state')"
definition "assert_simplex' = (assert_cs assert_nsc_code :: 'i \<Rightarrow> 'i simplex_state' \<Rightarrow> 'i list + 'i simplex_state')"
definition "check_simplex' = (check_cs check_nsc_code :: 'i simplex_state' \<Rightarrow> 'i list + 'i simplex_state')"
definition "solution_simplex' = (solution_cs solution_nsc_code from_ns :: 'i simplex_state' \<Rightarrow> _)"
definition "backtrack_simplex' = (backtrack_cs backtrack_nsc_code :: _ \<Rightarrow> 'i simplex_state' \<Rightarrow> _)"
definition "checkpoint_simplex' = (checkpoint_cs checkpoint_nsc_code :: 'i simplex_state' \<Rightarrow> _)"
definition "invariant_simplex' = Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex.invariant_cs invariant_nsc to_ns"
definition "checked_simplex' = Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex.checked_cs checked_nsc to_ns"

lemma case_sum_case_sum: "(case (case x of Inl y \<Rightarrow> Inl (f1 y) | Inr z \<Rightarrow> Inr (f2 z))
  of Inl y \<Rightarrow> Inl (g1 y) | Inr z \<Rightarrow> Inr (g2 z)) = (case x of Inl y \<Rightarrow> Inl (g1 (f1 y)) | Inr z \<Rightarrow> Inr (g2 (f2 z)))"
  by (cases x, auto)

text \<open>The following code-lemmas unfold some layers in the code of the simplex-operations,
  so that the implementation immediately points to
  the operations working on simplex type @{typ "('i,QDelta) state"}.\<close>

lemmas code_lemmas =
  fun_cong[OF init_simplex'_def, of cs for cs, unfolded init_cs_def
    Incremental_Atom_Ops_For_NS_Constraint_Ops_Default.init_nsc_def]
  fun_cong[OF fun_cong[OF assert_simplex'_def], of i "(cs,((asi,tv,ui),s))" for i cs asi tv ui s,
    unfolded assert_cs.simps assert_nsc_code_def assert_nsc_def case_sum_case_sum split]
  fun_cong[OF check_simplex'_def, of "(cs,(asi_tv,s))" for cs asi_tv s,
    unfolded check_cs_def check_nsc_code_def check_nsc_def sum_wrap.simps case_sum_case_sum]
  fun_cong[OF solution_simplex'_def, of "(cs,((asi,tv),s))" for cs asi tv s,
    unfolded solution_cs.simps solution_nsc_code_def solution_nsc.simps]
  fun_cong[OF checkpoint_simplex'_def, of "(cs,(asi_tv,s))" for cs asi_tv s,
    unfolded checkpoint_nsc_code_def checkpoint_cs.simps checkpoint_nsc.simps]
  fun_cong[OF fun_cong[OF backtrack_simplex'_def], of c "(cs,(asi_tv,s))" for c cs asi_tv s,
    unfolded backtrack_nsc_code_def backtrack_nsc.simps backtrack_cs.simps]

declare code_lemmas[code]

global_interpretation Incremental_Simplex:
  Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex
  init_nsc_code assert_nsc_code check_nsc_code solution_nsc_code checkpoint_nsc_code backtrack_nsc_code
  invariant_nsc checked_nsc to_ns from_ns
  rewrites
    "init_cs init_nsc_code to_ns = init_simplex'" and
    "backtrack_cs backtrack_nsc_code = backtrack_simplex'" and
    "checkpoint_cs checkpoint_nsc_code = checkpoint_simplex'" and
    "check_cs check_nsc_code = check_simplex'" and
    "assert_cs assert_nsc_code = assert_simplex'" and
    "solution_cs solution_nsc_code from_ns = solution_simplex'" and
    "Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex.invariant_cs invariant_nsc to_ns = invariant_simplex'" and
    "Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex.checked_cs checked_nsc to_ns = checked_simplex'"
proof -
  interpret Incremental_NS_Constraint_Ops init_nsc_code assert_nsc_code check_nsc_code solution_nsc_code checkpoint_nsc_code
    backtrack_nsc_code invariant_nsc checked_nsc
    using Incremental_Atom_Ops_For_NS_Constraint_Ops_Default.ns_constraints_ops .
  show "Incremental_NS_Constraint_Ops_To_Ns_For_Incremental_Simplex init_nsc_code assert_nsc_code check_nsc_code
     solution_nsc_code checkpoint_nsc_code backtrack_nsc_code invariant_nsc checked_nsc to_ns from_ns"
    ..
qed (auto simp:
    init_simplex'_def
    check_simplex'_def
    solution_simplex'_def
    backtrack_simplex'_def
    checkpoint_simplex'_def
    assert_simplex'_def
    invariant_simplex'_def
    checked_simplex'_def
    )

subsubsection \<open>An implementation which encapsulates the state\<close>

text \<open>In principle, we now already have a complete implementation of the incremental simplex algorithm with
  @{const init_simplex'}, @{const assert_simplex'}, etc. However, this implementation results in code where
  the interal type @{typ "'i simplex_state'"} becomes visible. Therefore, we now define all operations
  on a new type which encapsulates the internal construction.\<close>

datatype 'i simplex_state = Simplex_State "'i simplex_state'"
datatype 'i simplex_checkpoint = Simplex_Checkpoint "(nat, 'i \<times> QDelta) mapping \<times> (nat, 'i \<times> QDelta) mapping"

fun init_simplex where "init_simplex cs =
  (let tons_cs = to_ns cs
   in Simplex_State (map snd tons_cs,
       case preprocess tons_cs of (t, as, trans_v, ui) \<Rightarrow> ((create_map as, trans_v, remdups ui), init_state t)))"

fun assert_simplex where "assert_simplex i (Simplex_State (cs, (asi, tv, ui), s)) =
  (if i \<in> set ui then Inl [i] else case assert_all_s (list_map_to_fun asi i) s of Inl y \<Rightarrow> Inl y | Inr s' \<Rightarrow> Inr (Simplex_State (cs, (asi, tv, ui), s')))"

fun check_simplex where
  "check_simplex (Simplex_State (cs, asi_tv, s)) = (case check_s s of Inl y \<Rightarrow> Inl y | Inr s' \<Rightarrow> Inr (Simplex_State (cs, asi_tv, s')))"

fun solution_simplex where
  "solution_simplex (Simplex_State (cs, (asi, tv, ui), s)) = \<langle>from_ns (tv (\<V> s)) cs\<rangle>"

fun checkpoint_simplex where "checkpoint_simplex (Simplex_State (cs, asi_tv, s)) = Simplex_Checkpoint (checkpoint_s s)"

fun backtrack_simplex where
  "backtrack_simplex (Simplex_Checkpoint c) (Simplex_State (cs, asi_tv, s)) = Simplex_State (cs, asi_tv, backtrack_s c s)"

subsubsection \<open>Soundness of the incremental simplex implementation\<close>

text \<open>First link the unprimed constants against their primed counterparts.\<close>

lemma init_simplex': "init_simplex cs = Simplex_State (init_simplex' cs)"
  by (simp add: code_lemmas Let_def)

lemma assert_simplex': "assert_simplex i (Simplex_State s) = map_sum id Simplex_State (assert_simplex' i s)"
  by (cases s, auto simp: code_lemmas split: sum.splits)

lemma check_simplex': "check_simplex (Simplex_State s) = map_sum id Simplex_State (check_simplex' s)"
  by (cases s, auto simp: code_lemmas split: sum.splits)

lemma solution_simplex': "solution_simplex (Simplex_State s) = solution_simplex' s"
  by (cases s, auto simp: code_lemmas)

lemma checkpoint_simplex': "checkpoint_simplex (Simplex_State s) = Simplex_Checkpoint (checkpoint_simplex' s)"
  by (cases s, auto simp: code_lemmas split: sum.splits)

lemma backtrack_simplex': "backtrack_simplex (Simplex_Checkpoint c) (Simplex_State s) = Simplex_State (backtrack_simplex' c s)"
  by (cases s, auto simp: code_lemmas split: sum.splits)

fun invariant_simplex where
  "invariant_simplex cs J (Simplex_State s) = invariant_simplex' cs J s"

fun checked_simplex where
  "checked_simplex cs J (Simplex_State s) = checked_simplex' cs J s"

text \<open>Hide implementation\<close>

declare init_simplex.simps[simp del]
declare assert_simplex.simps[simp del]
declare check_simplex.simps[simp del]
declare solution_simplex.simps[simp del]
declare checkpoint_simplex.simps[simp del]
declare backtrack_simplex.simps[simp del]

text \<open>Soundness lemmas\<close>

lemma assert_simplex_ok:
  "invariant_simplex cs J s \<Longrightarrow> assert_simplex j s = Inr s' \<Longrightarrow> invariant_simplex cs (insert j J) s'"
proof (cases s)
  case s: (Simplex_State ss)
  show "invariant_simplex cs J s \<Longrightarrow> assert_simplex j s = Inr s' \<Longrightarrow> invariant_simplex cs (insert j J) s'"
    unfolding s invariant_simplex.simps assert_simplex' using Incremental_Simplex.assert_cs_ok[of cs J ss j]
    by (cases "assert_simplex' j ss", auto)
qed

lemma assert_simplex_unsat:
  "invariant_simplex cs J s \<Longrightarrow> assert_simplex j s = Inl I \<Longrightarrow>
     set I \<subseteq> insert j J \<and> minimal_unsat_core (set I) cs"
proof (cases s)
  case s: (Simplex_State ss)
  show "invariant_simplex cs J s \<Longrightarrow> assert_simplex j s = Inl I \<Longrightarrow>
    set I \<subseteq> insert j J \<and> minimal_unsat_core (set I) cs"
    unfolding s invariant_simplex.simps assert_simplex'
    using Incremental_Simplex.assert_cs_unsat[of cs J ss j]
    by (cases "assert_simplex' j ss", auto)
qed

lemma check_simplex_ok:
  "invariant_simplex cs J s \<Longrightarrow> check_simplex s = Inr s' \<Longrightarrow> checked_simplex cs J s'"
proof (cases s)
  case s: (Simplex_State ss)
  show "invariant_simplex cs J s \<Longrightarrow> check_simplex s = Inr s' \<Longrightarrow> checked_simplex cs J s'"
    unfolding s invariant_simplex.simps check_simplex.simps check_simplex' using Incremental_Simplex.check_cs_ok[of cs J ss]
    by (cases "check_simplex' ss", auto)
qed

lemma check_simplex_unsat:
  "invariant_simplex cs J s \<Longrightarrow> check_simplex s = Unsat I \<Longrightarrow>
     set I \<subseteq> J \<and> minimal_unsat_core (set I) cs"
proof (cases s)
  case s: (Simplex_State ss)
  show "invariant_simplex cs J s \<Longrightarrow> check_simplex s = Unsat I \<Longrightarrow>
    set I \<subseteq> J \<and> minimal_unsat_core (set I) cs"
    unfolding s invariant_simplex.simps check_simplex.simps check_simplex'
    using Incremental_Simplex.check_cs_unsat[of cs J ss I]
    by (cases "check_simplex' ss", auto)
qed

lemma solution_simplex:
  "checked_simplex cs J s \<Longrightarrow> solution_simplex s = v \<Longrightarrow> (J, v) \<Turnstile>\<^sub>i\<^sub>c\<^sub>s set cs"
  using Incremental_Simplex.solution_cs[of cs J]
  by (cases s, auto simp: solution_simplex')

lemma backtrack_simplex:
  "checked_simplex cs J s \<Longrightarrow>
   checkpoint_simplex s = c \<Longrightarrow>
   invariant_simplex cs K s' \<Longrightarrow>
   backtrack_simplex c s' = s'' \<Longrightarrow>
   J \<subseteq> K \<Longrightarrow>
   invariant_simplex cs J s''"
proof -
  obtain ss where ss: "s = Simplex_State ss" by (cases s, auto)
  obtain ss' where ss': "s' = Simplex_State ss'" by (cases s', auto)
  obtain ss'' where ss'': "s'' = Simplex_State ss''" by (cases s'', auto)
  obtain cc where cc: "c = Simplex_Checkpoint cc" by (cases c, auto)
  show "checked_simplex cs J s \<Longrightarrow>
   checkpoint_simplex s = c \<Longrightarrow>
   invariant_simplex cs K s' \<Longrightarrow>
   backtrack_simplex c s' = s'' \<Longrightarrow>
   J \<subseteq> K \<Longrightarrow>
   invariant_simplex cs J s''"
    unfolding ss ss' ss'' cc checked_simplex.simps invariant_simplex.simps checkpoint_simplex' backtrack_simplex'
    using Incremental_Simplex.backtrack_cs[of cs J ss cc K ss' ss''] by simp
qed

lemma checked_invariant_simplex:
  "checked_simplex cs J s \<Longrightarrow> invariant_simplex cs J s"
  using Incremental_Simplex.checked_invariant_cs[of cs J] by (cases s, auto)

declare checked_simplex.simps[simp del]
declare invariant_simplex.simps[simp del]

text \<open>From this point onwards, one should not look into the types @{typ "'i simplex_state"}
  and @{typ "'i simplex_checkpoint"}.\<close>

text \<open>For convenience: an assert-all function which takes multiple indices.\<close>

fun assert_all_simplex :: "'i list \<Rightarrow> 'i simplex_state \<Rightarrow> 'i list + 'i simplex_state" where
  "assert_all_simplex [] s = Inr s"
| "assert_all_simplex (j # J) s = (case assert_simplex j s of Unsat I \<Rightarrow> Unsat I
     | Inr s' \<Rightarrow> assert_all_simplex J s')"

lemma assert_all_simplex_ok: "invariant_simplex cs J s \<Longrightarrow> assert_all_simplex K s = Inr s' \<Longrightarrow>
    invariant_simplex cs (J \<union> set K) s'"
proof (induct K arbitrary: s J)
  case (Cons k K s J)
  from Cons(3) obtain s'' where ass: "assert_simplex k s = Inr s''" and rec: "assert_all_simplex K s'' = Inr s'"
    by (auto split: sum.splits)
  from Cons(1)[OF assert_simplex_ok[OF Cons(2) ass] rec]
  show ?case by auto
qed auto

lemma assert_all_simplex_unsat: "invariant_simplex cs J s \<Longrightarrow> assert_all_simplex K s = Unsat I \<Longrightarrow>
    set I \<subseteq> set K \<union> J \<and> minimal_unsat_core (set I) cs"
proof (induct K arbitrary: s J)
  case (Cons k K s J)
  show ?case
  proof (cases "assert_simplex k s")
    case unsat: (Inl J')
    with Cons have J': "J' = I" by auto
    from assert_simplex_unsat[OF Cons(2) unsat]
    have "set J' \<subseteq> insert k J" "minimal_unsat_core (set J') cs" by auto
    then show ?thesis unfolding J' i_satisfies_cs.simps
      by auto
  next
    case (Inr s')
    from Cons(1)[OF assert_simplex_ok[OF Cons(2) Inr]] Cons(3) Inr show ?thesis by auto
  qed
qed simp

text \<open>The collection of soundness lemmas for the incremental simplex algorithm.\<close>

lemmas incremental_simplex =
  init_simplex
  assert_simplex_ok
  assert_simplex_unsat
  assert_all_simplex_ok
  assert_all_simplex_unsat
  check_simplex_ok
  check_simplex_unsat
  solution_simplex
  backtrack_simplex
  checked_invariant_simplex

subsection \<open>Test Executability and Example for Incremental Interface\<close>

value (code) "let cs = [
    (1 :: int, LT (lp_monom 1 1) 4), \<comment> \<open>$x_1 < 4$\<close>
    (2, GTPP (lp_monom 2 1) (lp_monom 1 2)), \<comment> \<open>$2x_1 > x_2$\<close>
    (3, EQPP (lp_monom 1 1) (lp_monom 2 2)), \<comment> \<open>$x_1 = 2x_2$\<close>
    (4, GT (lp_monom 2 2) 5), \<comment> \<open>$2x_2 > 5$\<close>
    (5, GT (lp_monom 3 0) 7), \<comment> \<open>$3x_0 > 7$\<close>
    (6, GT (lp_monom 3 3 + lp_monom (1/3) 2) 2)]; \<comment> \<open>$3x_3 + 1/3x_2 > 2$\<close>
    s1 = init_simplex cs; \<comment> \<open>initialize\<close>
    s2 = (case assert_all_simplex [1,2,3] s1 of Inr s \<Rightarrow> s | Unsat _ \<Rightarrow> undefined); \<comment> \<open>assert 1,2,3\<close>
    s3 = (case check_simplex s2 of Inr s \<Rightarrow> s | Unsat _ \<Rightarrow> undefined); \<comment> \<open>check that 1,2,3 are sat.\<close>
    c123 = checkpoint_simplex s3; \<comment> \<open>after check, store checkpoint for backtracking\<close>
    s4 = (case assert_simplex 4 s2 of Inr s \<Rightarrow> s | Unsat _ \<Rightarrow> undefined); \<comment> \<open>assert 4\<close>
    I = (case check_simplex s4 of Unsat I \<Rightarrow> I | Inr _ \<Rightarrow> undefined); \<comment> \<open>checking detects unsat-core 1,3,4\<close>
    s5 = backtrack_simplex c123 s4; \<comment> \<open>backtrack to constraints 1,2,3\<close>
    s6 = (case assert_all_simplex [5,6] s5 of Inr s \<Rightarrow> s | Unsat _ \<Rightarrow> undefined); \<comment> \<open>assert 5,6\<close>
    s7 = (case check_simplex s6 of Inr s \<Rightarrow> s | Unsat _ \<Rightarrow> undefined); \<comment> \<open>check that 1,2,3,5,6 are sat.\<close>
    sol = solution_simplex s7 \<comment> \<open>solution for 1,2,3,5,6\<close>
  in (I, map (\<lambda> x. (''x_'', x, ''='', sol x)) [0,1,2,3]) \<comment> \<open>output unsat core and solution\<close>"
end


(*  Title:      Containers/Collection_Enum.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)

theory Collection_Enum imports
  Containers_Auxiliary
  Containers_Generator
begin

section \<open>A type class for optional enumerations\<close>

subsection \<open>Definition\<close>

class cenum =
  fixes cEnum :: "('a list \<times> (('a \<Rightarrow> bool) \<Rightarrow> bool) \<times> (('a \<Rightarrow> bool) \<Rightarrow> bool)) option"
  assumes UNIV_cenum: "cEnum = Some (enum, enum_all, enum_ex) \<Longrightarrow> UNIV = set enum"
  and cenum_all_UNIV: "cEnum = Some (enum, enum_all, enum_ex) \<Longrightarrow> enum_all P = Ball UNIV P"
  and cenum_ex_UNIV: "cEnum = Some (enum, enum_all, enum_ex) \<Longrightarrow> enum_ex P = Bex UNIV P"
begin

lemma ID_cEnum:
  "ID cEnum = Some (enum, enum_all, enum_ex)
  \<Longrightarrow> UNIV = set enum \<and> enum_all = Ball UNIV \<and> enum_ex = Bex UNIV"
unfolding ID_def id_apply fun_eq_iff
by(intro conjI allI UNIV_cenum cenum_all_UNIV cenum_ex_UNIV fun_eq_iff)

lemma in_cenum: "ID cEnum = Some (enum, rest) \<Longrightarrow> f \<in> set enum"
by(cases rest)(auto dest: ID_cEnum)

abbreviation cenum :: "'a list"
where "cenum \<equiv> fst (the (ID cEnum))"

abbreviation cenum_all :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
where "cenum_all \<equiv> fst (snd (the (ID cEnum)))"

abbreviation cenum_ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
where "cenum_ex \<equiv> snd (snd (the (ID cEnum)))"

end

syntax "_CENUM" :: "type => logic"  ("(1CENUM/(1'(_')))")

parse_translation \<open>
let
  fun cenum_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "cEnum"} $
       (Syntax.const @{type_syntax option} $
         (Syntax.const @{type_syntax prod} $
           (Syntax.const @{type_syntax list} $ ty) $
           (Syntax.const @{type_syntax prod} $
             (Syntax.const @{type_syntax fun} $
               (Syntax.const @{type_syntax fun} $ ty $ (Syntax.const @{type_syntax bool})) $
               (Syntax.const @{type_syntax bool})) $
             (Syntax.const @{type_syntax fun} $
               (Syntax.const @{type_syntax fun} $ ty $ (Syntax.const @{type_syntax bool})) $
               (Syntax.const @{type_syntax bool}))))))
    | cenum_tr ts = raise TERM ("cenum_tr", ts);
in [(@{syntax_const "_CENUM"}, K cenum_tr)] end
\<close>

typed_print_translation \<open>
let
  fun cenum_tr' ctxt
    (Type (@{type_name option}, [Type (@{type_name prod}, [Type (@{type_name list}, [T]), _])])) ts =
    Term.list_comb (Syntax.const @{syntax_const "_CENUM"} $ Syntax_Phases.term_of_typ ctxt T, ts)
  | cenum_tr' _ _ _ = raise Match;
in [(@{const_syntax cEnum}, cenum_tr')]
end
\<close>

subsection \<open>Generator for the @{class cenum}-class\<close>

text \<open>
This generator registers itself at the derive-manager for the class @{class cenum}.
To be more precise, one can currently only choose to not support enumeration
by passing "no" as parameter.

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (no) cenum}
\end{itemize}
\<close>

text \<open>
This generator can be used for arbitrary types, not just datatypes.
\<close>

ML_file \<open>cenum_generator.ML\<close>

subsection \<open>Instantiations\<close>

context fixes cenum_all :: "('a \<Rightarrow> bool) \<Rightarrow> bool" begin
fun all_n_lists :: "('a list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
where [simp del]:
  "all_n_lists P n = (if n = 0 then P [] else cenum_all (\<lambda>x. all_n_lists (\<lambda>xs. P (x # xs)) (n - 1)))"
end

context fixes cenum_ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool" begin
fun ex_n_lists :: "('a list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
where [simp del]:
  "ex_n_lists P n \<longleftrightarrow> (if n = 0 then P [] else cenum_ex (%x. ex_n_lists (%xs. P (x # xs)) (n - 1)))"
end

lemma all_n_lists_iff: fixes cenum shows
  "all_n_lists (Ball (set cenum)) P n \<longleftrightarrow> (\<forall>xs \<in> set (List.n_lists n cenum). P xs)"
proof(induct P n rule: all_n_lists.induct)
  case (1 P n)
  show ?case
  proof(cases n)
    case 0
    thus ?thesis by(simp add: all_n_lists.simps)
  next
    case (Suc n')
    thus ?thesis using "1" by(subst all_n_lists.simps) auto
  qed
qed

lemma ex_n_lists_iff: fixes cenum shows
  "ex_n_lists (Bex (set cenum)) P n \<longleftrightarrow> (\<exists>xs \<in> set (List.n_lists n cenum). P xs)"
proof(induct P n rule: ex_n_lists.induct)
  case (1 P n)
  show ?case
  proof(cases n)
    case 0
    thus ?thesis by(simp add: ex_n_lists.simps)
  next
    case (Suc n')
    thus ?thesis using "1" by(subst ex_n_lists.simps) auto
  qed
qed

instantiation "fun" :: (cenum, cenum) cenum begin

definition
  "CENUM('a \<Rightarrow> 'b) =
  (case ID CENUM('a) of None \<Rightarrow> None | Some (enum_a, enum_all_a, enum_ex_a) \<Rightarrow>
     case ID CENUM('b) of None \<Rightarrow> None | Some (enum_b, enum_all_b, enum_ex_b) \<Rightarrow> Some
       (map (\<lambda>ys. the o map_of (zip enum_a ys)) (List.n_lists (length enum_a) enum_b),
        \<lambda>P. all_n_lists enum_all_b (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a),
        \<lambda>P. ex_n_lists enum_ex_b (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a)))"
instance proof
  fix enum enum_all enum_ex P
  assume "CENUM('a \<Rightarrow> 'b) = Some (enum, enum_all, enum_ex)"
  then obtain enum_a enum_all_a enum_ex_a enum_b enum_all_b enum_ex_b
    where a: "ID CENUM('a) = Some (enum_a, enum_all_a, enum_ex_a)"
    and b: "ID CENUM('b) = Some (enum_b, enum_all_b, enum_ex_b)"
    and enum: "enum = map (\<lambda>ys. the o map_of (zip enum_a ys)) (List.n_lists (length enum_a) enum_b)"
    and enum_all: "enum_all = (\<lambda>P. all_n_lists enum_all_b (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a))"
    and enum_ex: "enum_ex = (\<lambda>P. ex_n_lists enum_ex_b (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a))"
    by(fastforce simp add: cEnum_fun_def split: option.split_asm)

  show "UNIV = set enum"
  proof (rule UNIV_eq_I)
    fix f :: "'a \<Rightarrow> 'b"
    have "f = the \<circ> map_of (zip enum_a (map f enum_a))"
      by (auto simp add: map_of_zip_map fun_eq_iff intro: in_cenum[OF a])
    then show "f \<in> set enum"
      by (auto simp add: enum set_n_lists intro: in_cenum[OF b])
  qed

  show "enum_all P = Ball UNIV P"
  proof
    assume "enum_all P"
    show "Ball UNIV P"
    proof
      fix f :: "'a \<Rightarrow> 'b"
      have f: "f = the \<circ> map_of (zip (enum_a) (map f enum_a))"
        by (auto simp add: map_of_zip_map fun_eq_iff intro: in_cenum[OF a])
      from \<open>enum_all P\<close> have "P (the \<circ> map_of (zip enum_a (map f enum_a)))"
        apply(simp add: enum_all ID_cEnum[OF b] all_n_lists_iff set_n_lists)
        apply(erule allE, erule mp)
        apply(auto simp add: in_cenum[OF b])
        done
      with f show "P f" by simp
    qed
  next
    assume "Ball UNIV P"
    from this show "enum_all P"
      by(simp add: enum_all ID_cEnum[OF b] all_n_lists_iff)
  qed

  show "enum_ex P = Bex UNIV P"
  proof
    assume "enum_ex P"
    from this show "Bex UNIV P"
      by(auto simp add: enum_ex ID_cEnum[OF b] ex_n_lists_iff)
  next
    assume "Bex UNIV P"
    from this obtain f where "P f" ..
    also have f: "f = the \<circ> map_of (zip (enum_a) (map f enum_a))"
      by (auto simp add: map_of_zip_map fun_eq_iff intro: in_cenum[OF a])
    finally show "enum_ex P"
      apply(simp add: enum_ex ID_cEnum[OF b] ex_n_lists_iff o_def)
      apply(erule bexI)
      apply(auto simp add: set_n_lists intro!: in_cenum[OF b])
      done
  qed
qed
end

instantiation set :: (cenum) cenum begin
definition
  "CENUM('a set) =
  (case ID CENUM('a) of None \<Rightarrow> None | Some (enum_a, enum_all_a, enum_ex_a) \<Rightarrow> Some
    (map set (subseqs enum_a),
     \<lambda>P. list_all P (map set (subseqs enum_a)),
     \<lambda>P. list_ex P (map set (subseqs enum_a))))"
instance
  by(intro_classes)(auto simp add: cEnum_set_def subseqs_powset list_ex_iff list_all_iff split: option.split_asm dest!: ID_cEnum)
end

instantiation unit :: cenum begin
definition "CENUM(unit) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_unit_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation bool :: cenum begin
definition "CENUM(bool) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_bool_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation prod :: (cenum, cenum) cenum begin
definition
  "CENUM('a \<times> 'b) =
  (case ID CENUM('a) of None \<Rightarrow> None | Some (enum_a, enum_all_a, enum_ex_a) \<Rightarrow>
     case ID CENUM('b) of None \<Rightarrow> None | Some (enum_b, enum_all_b, enum_ex_b) \<Rightarrow> Some
       (List.product enum_a enum_b,
        \<lambda>P. enum_all_a (%x. enum_all_b (%y. P (x, y))),
        \<lambda>P. enum_ex_a (%x. enum_ex_b (%y. P (x, y)))))"
instance
  by(intro_classes)(auto 4 4 simp add: cEnum_prod_def split: option.split_asm dest!: ID_cEnum)
end

instantiation sum :: (cenum, cenum) cenum begin
definition
  "CENUM('a + 'b) =
  (case ID CENUM('a) of None \<Rightarrow> None | Some (enum_a, enum_all_a, enum_ex_a) \<Rightarrow>
     case ID CENUM('b) of None \<Rightarrow> None | Some (enum_b, enum_all_b, enum_ex_b) \<Rightarrow> Some
       (map Inl enum_a @ map Inr enum_b,
        \<lambda>P. enum_all_a (\<lambda>x. P (Inl x)) \<and> enum_all_b (\<lambda>x. P (Inr x)),
        \<lambda>P. enum_ex_a (\<lambda>x. P (Inl x)) \<or> enum_ex_b (\<lambda>x. P (Inr x))))"
instance
  by(intro_classes)(auto 4 4 simp add: cEnum_sum_def UNIV_sum split: option.split_asm dest!: ID_cEnum)
end

instantiation option :: (cenum) cenum begin
definition
  "CENUM('a option) =
  (case ID CENUM('a) of None \<Rightarrow> None | Some (enum_a, enum_all_a, enum_ex_a) \<Rightarrow> Some
    (None # map Some enum_a,
     \<lambda>P. P None \<and> enum_all_a (\<lambda>x. P (Some x)),
     \<lambda>P. P None \<or> enum_ex_a (\<lambda>x. P (Some x))))"
instance
  by(intro_classes)(auto simp add: cEnum_option_def UNIV_option_conv split: option.split_asm dest: ID_cEnum)
end

instantiation Enum.finite_1 :: cenum begin
definition "CENUM(Enum.finite_1) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_finite_1_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation Enum.finite_2 :: cenum begin
definition "CENUM(Enum.finite_2) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_finite_2_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation Enum.finite_3 :: cenum begin
definition "CENUM(Enum.finite_3) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_finite_3_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation Enum.finite_4 :: cenum begin
definition "CENUM(Enum.finite_4) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_finite_4_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation Enum.finite_5 :: cenum begin
definition "CENUM(Enum.finite_5) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_finite_5_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

instantiation char :: cenum begin
definition "CENUM(char) = Some (enum_class.enum, enum_class.enum_all, enum_class.enum_ex)"
instance by(intro_classes)(auto simp add: cEnum_char_def enum_UNIV enum_all_UNIV enum_ex_UNIV)
end

derive (no) cenum list nat int integer natural String.literal

end