section \<open>Implementation of the Edmonds-Karp Algorithm\<close>
theory EdmondsKarp_Refine
imports
  EdmondsKarp_Algo
  Augmenting_Path_BFS
  "../../Refine_Imperative_HOL/IICF/IICF"
  "../../Refine_Imperative_HOL/IICF/IICF_Misc"
begin
  hide_const R B

  text \<open>We now implement the Edmonds-Karp algorithm.
    Note that, during the implementation, we explicitly write down the
    whole refined algorithm several times. As refinement is modular, most
    of these copies could be avoided--- we inserted them deliberately for
    documentation purposes.
    \<close>

  subsection \<open>Refinement to Residual Graph\<close>
    text \<open>As a first step towards implementation, we refine the algorithm
      to work directly on residual graphs. For this, we first have to
      establish a relation between flows in a network and residual graphs.
      \<close>

  subsubsection \<open>Refinement of Operations\<close>
  context Network
  begin
    text \<open>We define the relation between residual graphs and flows\<close>
    definition "cfi_rel \<equiv> br flow_of_cf (RGraph c s t)"

    text \<open>It can also be characterized the other way round, i.e.,
      mapping flows to residual graphs:\<close>
    lemma cfi_rel_alt: "cfi_rel = {(cf,f). cf = residualGraph c f \<and> NFlow c s t f}"
      unfolding cfi_rel_def br_def
      by (auto
          simp: NFlow.is_RGraph RGraph.is_NFlow
          simp: RPreGraph.rg_fo_inv[OF RGraph.this_loc_rpg]
          simp: NPreflow.fo_rg_inv[OF NFlow.axioms(1)])

    text \<open>Initially, the residual graph for the zero flow equals the original network\<close>
    lemma residualGraph_zero_flow: "residualGraph c (\<lambda>_. 0) = c"
      unfolding residualGraph_def by (auto intro!: ext)
    lemma flow_of_c: "flow_of_cf c = (\<lambda>_. 0)"
      by (auto simp add: flow_of_cf_def[abs_def])

    text \<open>The residual capacity is naturally defined on residual graphs\<close>
    definition "resCap_cf cf p \<equiv> Min {cf e | e. e\<in>set p}"
    lemma (in NFlow) resCap_cf_refine: "resCap_cf cf p = resCap p"
      unfolding resCap_cf_def resCap_def ..

    text \<open>Augmentation can be done by @{const Graph.augment_cf}.\<close>

    lemma (in NFlow) augment_cf_refine_aux: (* For snippet *)
      assumes AUG: "isAugmentingPath p"
      shows "residualGraph c (augment (augmentingFlow p)) (u,v) = (
        if (u,v)\<in>set p then (residualGraph c f (u,v) - resCap p)
        else if (v,u)\<in>set p then (residualGraph c f (u,v) + resCap p)
        else residualGraph c f (u,v))"
      using augment_alt[OF AUG] by (auto simp: Graph.augment_cf_def)

    lemma augment_cf_refine:
      assumes R: "(cf,f)\<in>cfi_rel"
      assumes AUG: "NPreflow.isAugmentingPath c s t f p"
      shows "(Graph.augment_cf cf (set p) (resCap_cf cf p),
          NFlow.augment_with_path c f p) \<in> cfi_rel"
    proof -
      from R have [simp]: "cf = residualGraph c f" and "NFlow c s t f"
        by (auto simp: cfi_rel_alt br_def)
      then interpret f: NFlow c s t f by simp

      show ?thesis
        unfolding f.augment_with_path_def
      proof (simp add: cfi_rel_alt; safe intro!: ext)
        fix u v
        show "Graph.augment_cf f.cf (set p) (resCap_cf f.cf p) (u,v)
              = residualGraph c (f.augment (f.augmentingFlow p)) (u,v)"
          unfolding f.augment_cf_refine_aux[OF AUG]
          unfolding f.cf.augment_cf_def
          by (auto simp: f.resCap_cf_refine)
      qed (rule f.augment_pres_nflow[OF AUG])
    qed

    text \<open>We rephrase the specification of shortest augmenting path to
      take a residual graph as parameter\<close>
    (* TODO: This actually rephrases the spec to make it look more similar to
      what BFS does later. This rephrasing does not belong here, but where we
      implement it with BFS. *)
end
locale EdKa_Res = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes shortestpath_time :: nat
    and augment_with_path_time :: nat
     and init_graph :: "nat \<Rightarrow> nat"
  assumes augment_progress[simp]: "0 \<noteq> enat shortestpath_time"
begin

    interpretation Ed: EdKa c s t shortestpath_time augment_with_path_time
      apply standard by simp

    definition "find_shortest_augmenting_spec_cf cf \<equiv>
      ASSERT (RGraph c s t cf) \<then>
      SPECT (emb (\<lambda>
        None \<Rightarrow> \<not>Graph.connected cf s t
      | Some p \<Rightarrow> Graph.isShortestPath cf s p t) shortestpath_time)"

    lemma   find_shortest_augmenting_spec_cf_refine:
       "RGraph c s t cf \<Longrightarrow> find_shortest_augmenting_spec_cf cf \<le> Ed.find_shortest_augmenting_spec (flow_of_cf cf)"
    proof -
      assume R: "RGraph c s t cf"
      interpret RG: RGraph c s t cf by fact

      show ?thesis
      unfolding RPreGraph.f_def[symmetric]
      unfolding find_shortest_augmenting_spec_cf_def  apply(subst Ed.find_shortest_augmenting_spec_def)
      apply(rule le_ASSERTI) apply(rule ASSERT_leI) using R apply simp
      using Network_axioms apply(simp add: EdKa_def EdKa_axioms_def)
      by (auto
        simp: pw_le_iff refine_pw_simps Some_eq_emb'_conv numeral_eq_enat
        simp: RGraph.this_loc RPreGraph.rg_is_cf
        simp: RG.f.isAugmentingPath_def Graph.connected_def Graph.isSimplePath_def
        dest: RG.cf.shortestPath_is_path
        split: option.split)
  qed

    text \<open>This leads to the following refined algorithm\<close>
    definition  "edka2 \<equiv> do {
      cf \<leftarrow>  SPECT [c \<mapsto> init_graph (card V)];

      (cf,_) \<leftarrow> whileT
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          ASSERT (RGraph c s t cf);
          p \<leftarrow> find_shortest_augmenting_spec_cf cf;
          case p of
            None \<Rightarrow> RETURNT (cf,True)
          | Some p \<Rightarrow> do {
              ASSERT (p\<noteq>[]);
              ASSERT (Graph.isShortestPath cf s p t);
              cf \<leftarrow> SPECT [Graph.augment_cf cf (set p) (resCap_cf cf p) \<mapsto> augment_with_path_time];
              ASSERT (RGraph c s t cf);
              RETURNT (cf, False)
            }
        })
        (cf,False);
      ASSERT (RGraph c s t cf);
      f \<leftarrow> RETURNT (flow_of_cf cf);
      RETURNT f
    }"

    lemma  edka2_refine: "edka2 \<le> \<Down>Id Ed.edka"
    proof -
      have [refine_dref_RELATES]: "RELATES cfi_rel" by (simp add: RELATES_def)

      show ?thesis
        unfolding edka2_def Ed.edka_def
        apply(refine_rcg find_shortest_augmenting_spec_cf_refine RETURNT_refine SPECT_refine)
        apply refine_dref_type
        apply simp_all

        \<comment> \<open>Solve some left-over verification conditions one by one\<close>
        subgoal by (auto simp add: cfi_rel_alt residualGraph_zero_flow zero_flow
                       split: if_splits)
        subgoal by (auto simp add: cfi_rel_alt NFlow.is_RGraph)
        subgoal by (auto dest!: find_shortest_augmenting_spec_cf_refine
                      simp add: cfi_rel_def in_br_conv)
        subgoal by (simp add: cfi_rel_alt)
        subgoal apply (auto split: if_splits simp add: cfi_rel_def in_br_conv )
            subgoal by (metis augment_cf_refine cfi_rel_def in_br_conv)
            subgoal by (metis augment_cf_refine cfi_rel_def in_br_conv)
            done
        subgoal by (metis (full_types)  cfi_rel_def in_br_conv)
        by (simp_all add: cfi_rel_def in_br_conv)
    qed

  lemma  edka2_correct: "edka2 \<le> \<Down>Id  (SPECT (emb isMaxFlow (enat Ed.edka_time)))"
    apply(rule order.trans) apply(rule edka2_refine) using Ed.edka_correct by simp

end

locale RGraph_impl = RGraph c s t cf for c :: "'capacity::linordered_idom graph" and s t cf +
  fixes matrix_lookup_time matrix_set_time :: nat
    assumes [simp]: "matrix_lookup_time > 0"
begin

    subsection \<open>Implementation of Bottleneck Computation and Augmentation\<close>
    text \<open>We will access the capacities in the residual graph
      only by a get-operation, which asserts that the edges are valid\<close>

    abbreviation (in Graph) (input) valid_edge :: "edge \<Rightarrow> bool" where
      "valid_edge \<equiv> \<lambda>(u,v). u\<in>V \<and> v\<in>V"

    definition (in Network) cf_get
      :: "'capacity graph \<Rightarrow> edge \<Rightarrow> nat \<Rightarrow> 'capacity nrest"
      where "cf_get cff e matrix_lookup_time \<equiv> ASSERT (valid_edge e) \<then> mop_matrix_get (\<lambda>_. matrix_lookup_time) cff e"
    definition (in Network) cf_set
      :: "'capacity graph \<Rightarrow> edge \<Rightarrow> 'capacity \<Rightarrow> nat \<Rightarrow> 'capacity graph nrest"
      where "cf_set cff e cap matrix_set_time \<equiv> ASSERT (valid_edge e) \<then> mop_matrix_set (\<lambda>_. matrix_set_time) cff e cap"

    definition (in Network) resCap_cf_impl_aux :: "nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'capacity) \<Rightarrow> (nat \<times> nat) list \<Rightarrow> 'capacity nrest"
    where "resCap_cf_impl_aux matrix_lookup_time cf p \<equiv>
      case p of
        [] \<Rightarrow> RETURNT (0::'capacity)
      | (e#p) \<Rightarrow> do {
          cap \<leftarrow> cf_get cf e matrix_lookup_time;
          ASSERT (distinct p);
          nfoldli
            p (\<lambda>_. True)
            (\<lambda>e cap. do {
              cape \<leftarrow> cf_get cf e matrix_lookup_time;
              mop_min 10 cape cap
            })
            cap
        }"

    abbreviation "resCap_cf_impl == resCap_cf_impl_aux matrix_lookup_time cf"

    definition (in -) "resCap_cf_impl_time_aux n v1 = 1 + (v1+10) * n"

    abbreviation "resCap_cf_impl_time n \<equiv> resCap_cf_impl_time_aux n matrix_lookup_time"

    lemma resCap_cf_impl_time_mono: "n \<le> m \<Longrightarrow> resCap_cf_impl_time n \<le> resCap_cf_impl_time m"
      unfolding resCap_cf_impl_time_aux_def by simp

    lemma  resCap_cf_impl_refine:
      assumes AUG: "cf.isSimplePath s p t"
      shows "resCap_cf_impl p \<le> SPECT (emb (\<lambda>r. r = resCap_cf cf p) (resCap_cf_impl_time (length p)))"
    proof -
      (* TODO: Can we exploit Min.set_eq_fold *)

      note [simp del] = Min_insert
      note [simp] = Min_insert[symmetric]
      from AUG[THEN cf.isSPath_distinct]
      have "distinct p" .
      moreover from AUG cf.isPath_edgeset have "set p \<subseteq> cf.E"
        by (auto simp: cf.isSimplePath_def)
      hence "set p \<subseteq> Collect valid_edge"
        using cf.E_ss_VxV by simp
      moreover from AUG have "p\<noteq>[]" by (auto simp: s_not_t)
        then obtain e p' where "p=e#p'" by (auto simp: neq_Nil_conv)
      ultimately show ?thesis
        unfolding resCap_cf_impl_aux_def resCap_cf_def cf_get_def
        apply (simp only: list.case)
        apply(rule T_specifies_I)
        apply(vcg'\<open>-\<close> rules: matrix_get )
          apply(rule nfoldli_rule[where I="\<lambda>l l' cap.
              cap = Min (cf`insert e (set l))
            \<and> set (l@l') \<subseteq> Collect valid_edge" and body_time="matrix_lookup_time+10"
              and P="(\<lambda>r. r = Min {cf ea |ea. ea \<in> set (e # p')})", THEN T_specifies_rev , THEN T_conseq4])

            apply (auto intro!: arg_cong[where f=Min])  []
        subgoal apply(rule T_specifies_I) apply(vcg'\<open>-\<close> rules: mop_min matrix_get)
          by (auto simp add: emb_le_Some_conv numeral_eq_enat intro!: arg_cong[where f=Min])
        apply (auto simp: emb_eq_Some_conv Some_le_emb'_conv resCap_cf_impl_time_aux_def intro!: arg_cong[where f=Min])
        subgoal by (progress \<open>clarsimp\<close>)
        done
    qed

    definition (in Graph)
      "augment_edge e cap \<equiv> (c(
                  e := c e - cap,
        prod.swap e := c (prod.swap e) + cap))"

    (* TODO: This would be much simpler to prove if we had a characterization
      of simple-path only depending on p. *)
    lemma (in Graph) augment_cf_inductive:
      fixes e cap s t
      defines "c' \<equiv> augment_edge e cap"
      assumes P: "isSimplePath s (e#p) t"
      shows "augment_cf (insert e (set p)) cap = Graph.augment_cf c' (set p) cap"
      and "\<exists>s'. Graph.isSimplePath c' s' p t"
    proof -
      obtain u v where [simp]: "e=(u,v)" by (cases e)

      from isSPath_no_selfloop[OF P] have [simp]: "\<And>u. (u,u)\<notin>set p" "u\<noteq>v" by auto

      from isSPath_nt_parallel[OF P] have [simp]: "(v,u)\<notin>set p" by auto
      from isSPath_distinct[OF P] have [simp]: "(u,v)\<notin>set p" by auto

      show "augment_cf (insert e (set p)) cap = Graph.augment_cf c' (set p) cap"
        apply (rule ext)
        unfolding Graph.augment_cf_def c'_def Graph.augment_edge_def
        by auto

      have "Graph.isSimplePath c' v p t"
        unfolding Graph.isSimplePath_def
        apply rule
        apply (rule transfer_path)
        unfolding Graph.E_def
        apply (auto simp: c'_def Graph.augment_edge_def) []
        using P apply (auto simp: isSimplePath_def) []
        using P apply (auto simp: isSimplePath_def) []
        done
      thus "\<exists>s'. Graph.isSimplePath c' s' p t" ..

    qed

    definition (in Network) "augment_edge_impl_aux matrix_lookup_time matrix_set_time cff e cap \<equiv> do {
      v \<leftarrow> cf_get cff e matrix_lookup_time; cf \<leftarrow> cf_set cff e (v-cap) matrix_set_time;
      e \<leftarrow> mop_swap 3 e;
      v \<leftarrow> cf_get cf e matrix_lookup_time; cf \<leftarrow> cf_set cf e (v+cap) matrix_set_time;
      RETURNT cf
    }"
    abbreviation "augment_edge_impl == augment_edge_impl_aux matrix_lookup_time matrix_set_time"

    definition (in -) "augment_edge_impl_time_aux v1 v2 = 2 * v1 + 2 * v2 + 3"
    abbreviation "augment_edge_impl_time == augment_edge_impl_time_aux matrix_lookup_time matrix_set_time"
    lemma augment_edge_impl_refine:
      assumes "valid_edge e" "\<forall>u. e\<noteq>(u,u)"
      shows "augment_edge_impl cff e cap
              \<le> SPECT (emb  (\<lambda>r. r = Graph.augment_edge cff e cap) augment_edge_impl_time)"
      using assms
      unfolding augment_edge_impl_aux_def Graph.augment_edge_def
      unfolding cf_get_def cf_set_def apply simp
      apply(rule T_specifies_I)
      apply (vcg'\<open>auto\<close> rules: matrix_get matrix_set mop_swap) apply (auto simp: emb_le_Some_conv augment_edge_impl_time_aux_def one_enat_def  numeral_eq_enat)
      done

    definition (in Network)  augment_cf_impl_aux
      where
      "augment_cf_impl_aux matrix_lookup_time matrix_set_time cff p x \<equiv> do {
        RECT (\<lambda>D. \<lambda>
          ([],cf) \<Rightarrow> RETURNT  cf
        | (e#p,cf) \<Rightarrow> do {
            cf \<leftarrow> augment_edge_impl_aux matrix_lookup_time matrix_set_time cf e x;
            D (p,cf)
          }
        ) (p,cff)
      }"

    abbreviation "augment_cf_impl cff p x == augment_cf_impl_aux matrix_lookup_time matrix_set_time cff p x"

    text \<open>Deriving the corresponding recursion equations\<close>
    lemma augment_cf_impl_simps[simp]:
      "augment_cf_impl cff [] x = RETURNT cff"
      "augment_cf_impl cff (e#p) x = do {
        cf \<leftarrow> augment_edge_impl cff e x;
        augment_cf_impl cf p x}"
      apply (simp add: augment_cf_impl_aux_def)
      apply (subst RECT_unfold, refine_mono)
      apply simp

      apply (simp add: augment_cf_impl_aux_def)
      apply (subst RECT_unfold, refine_mono)
      apply simp
      done

    definition (in -) "augment_cf_impl_time_aux n v1 =    1 + n * v1 "
    abbreviation "augment_cf_impl_time n \<equiv> augment_cf_impl_time_aux n augment_edge_impl_time"
    lemma augment_cf_impl_time_mono: "n \<le> m \<Longrightarrow> augment_cf_impl_time n \<le> augment_cf_impl_time m"
      unfolding augment_cf_impl_time_aux_def by simp

    lemma augment_cf_impl_aux:
      assumes "\<forall>e\<in>set p. valid_edge e"
      assumes "\<exists>s. Graph.isSimplePath cf s p t"
      shows "augment_cf_impl cf p x \<le> SPECT [Graph.augment_cf cf (set p) x\<mapsto> augment_cf_impl_time (length p)]"
      using assms unfolding augment_cf_impl_time_aux_def
    proof (induction p arbitrary: cf)
      case Nil
      then show ?case
        by (auto simp add: RETURNT_def le_fun_def one_enat_def Graph.augment_cf_empty)

    next
      case (Cons a p)

      from Cons(2,3)
      show ?case
      apply clarsimp
      apply (subst Graph.augment_cf_inductive, assumption)
      apply(rule T_specifies_I)
        apply (vcg'\<open>-\<close> rules:  )
        apply(rule  augment_edge_impl_refine[THEN T_specifies_rev , THEN T_conseq4])
          apply (auto dest: Graph.isSPath_no_selfloop)
        apply(rule Cons(1)[THEN T_specifies_rev , THEN T_conseq4])
          apply simp apply (auto simp add: emb_eq_Some_conv) []
            apply (drule Graph.augment_cf_inductive(2)[where cap=x]; simp)
        by (auto simp add: emb_eq_Some_conv split: if_splits)
      (*
      apply (refine_vcg augment_edge_impl_refine[THEN order_trans])
      apply simp
      apply simp
      apply (auto dest: Graph.isSPath_no_selfloop) []
      apply (rule order_trans, rprems)
        apply (drule Graph.augment_cf_inductive(2)[where cap=x]; simp)
        apply simp
      done  *)
    qed

    lemma augment_cf_impl_refine:
      assumes "Graph.isSimplePath cf s p t"
      shows "augment_cf_impl cf p x \<le> SPECT [Graph.augment_cf cf (set p) x\<mapsto> augment_cf_impl_time (length p)]"
      apply (rule augment_cf_impl_aux)
      using assms cf.E_ss_VxV apply (auto simp: cf.isSimplePath_def dest!: cf.isPath_edgeset) []
      using assms by blast
end

locale EdKa_Res_Up = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes shortestpath_time :: nat
    and matrix_lookup_time matrix_set_time :: nat
     and init_graph :: "nat \<Rightarrow> nat"
  assumes augment_progress[simp]: "0 \<noteq> enat shortestpath_time"
    assumes [simp]: "matrix_lookup_time > 0"
begin

    definition (in -) "augment_with_path_time_aux v1 v2 cV = RGraph_impl.resCap_cf_impl_time v1 cV
           + RGraph_impl.augment_cf_impl_time v1 v2 cV"

  abbreviation "augment_with_path_time \<equiv> augment_with_path_time_aux matrix_lookup_time matrix_set_time (card V)"

    thm  Finite_Graph.isShortestPath_length_less_V

lemma  tTT:
  fixes ss tt cc
  assumes  "Graph.isShortestPath cc ss p tt" "ss\<in>V" "RGraph c s t cc"
  shows "RGraph_impl.resCap_cf_impl_time matrix_lookup_time (length p)
              + RGraph_impl.augment_cf_impl_time matrix_lookup_time matrix_set_time (length p) \<le> augment_with_path_time "
proof -
  interpret R: RGraph c s t cc by fact

  from R.cf.isShortestPath_length_less_V assms have "length p < card V" by simp
  then have le: "length p \<le> card V" by auto

  thm RGraph_impl.augment_cf_impl_time_mono
  term RGraph_impl.resCap_cf_impl_time
  have "RGraph_impl.resCap_cf_impl_time matrix_lookup_time (length p) \<le> RGraph_impl.resCap_cf_impl_time matrix_lookup_time (card V)"
    apply(rule RGraph_impl.resCap_cf_impl_time_mono)
    using assms(3) le by (auto simp: RGraph_impl_def RGraph_impl_axioms_def)
  moreover
  have "RGraph_impl.augment_cf_impl_time matrix_lookup_time matrix_set_time (length p) \<le> RGraph_impl.augment_cf_impl_time matrix_lookup_time matrix_set_time (card V)"
    apply(rule RGraph_impl.augment_cf_impl_time_mono)
    using assms(3) le by (auto simp: RGraph_impl_def RGraph_impl_axioms_def)
  ultimately
  show ?thesis unfolding augment_with_path_time_aux_def by simp
qed

    interpretation Ed_Res: EdKa_Res c s t shortestpath_time augment_with_path_time
      apply standard by simp

lemmas find_shortest_augmenting_spec_cf = Ed_Res.find_shortest_augmenting_spec_cf_def

    abbreviation "resCap_cf_impl' cf p \<equiv> RGraph_impl.resCap_cf_impl c cf matrix_lookup_time p"
    abbreviation "augment_cf_impl' cf p bn \<equiv> RGraph_impl.augment_cf_impl c matrix_lookup_time matrix_set_time cf p bn"
    abbreviation "find_shortest_augmenting_spec_cf \<equiv> Ed_Res.find_shortest_augmenting_spec_cf"

    definition "augment cf p =  do {
                  bn \<leftarrow> resCap_cf_impl' cf p;
                  augment_cf_impl' cf p bn }"

    text \<open>Finally, we arrive at the algorithm where augmentation is
      implemented algorithmically: \<close>
    definition "edka3 \<equiv> do {
      cf \<leftarrow> SPECT [c \<mapsto> init_graph (card V)];

      (cf,_) \<leftarrow> whileT
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          ASSERT (RGraph c s t cf);
          p \<leftarrow> find_shortest_augmenting_spec_cf cf;
          case p of
            None \<Rightarrow> RETURNT (cf,True)
          | Some p \<Rightarrow> do {
              ASSERT (p\<noteq>[]);
              ASSERT (Graph.isShortestPath cf s p t);
              cf \<leftarrow> augment cf p;
              ASSERT (RGraph c s t cf);
              RETURNT (cf, False)
            }
        })
        (cf,False);
      ASSERT (RGraph c s t cf);
      f \<leftarrow> RETURNT (flow_of_cf cf);
      RETURNT f
    }"

  lemma augment_refine[refine]: "RGraph c s t x1  \<Longrightarrow> Graph.isShortestPath x1 s pc t \<Longrightarrow> x1'=x1 \<Longrightarrow> pc=pc' \<Longrightarrow>
     augment x1 pc \<le> \<Down>Id (SPECT [Graph.augment_cf x1' (set pc') (resCap_cf x1' pc') \<mapsto> enat augment_with_path_time])"
          unfolding augment_def apply simp
        apply(rule T_specifies_I)
        apply(vcg'\<open>-\<close> rules: RGraph_impl.resCap_cf_impl_refine[THEN T_specifies_rev , THEN T_conseq4]
             RGraph_impl.augment_cf_impl_refine[THEN T_specifies_rev , THEN T_conseq4]  )
        unfolding RGraph_impl_def apply (simp add: RGraph_impl_axioms_def)
           apply(auto simp: RGraph_impl_axioms_def intro:  Graph.shortestPath_is_simple)[]
        apply (simp add: RGraph_impl_axioms_def)
         apply(auto intro: Graph.shortestPath_is_simple)[]
        apply (auto split: if_splits simp: RGraph_impl_axioms_def emb_eq_Some_conv)
        apply(subst tTT )
        by auto

   lemma edka3_refine: "edka3 \<le> \<Down>Id Ed_Res.edka2"
      unfolding edka3_def Ed_Res.edka2_def
      apply (refine_rcg augment_refine)
      apply refine_dref_type
      by auto

  lemma  edka3_correct: "edka3 \<le> \<Down>Id (SPECT (emb isMaxFlow (enat (EdKa.edka_time c shortestpath_time augment_with_path_time init_graph))))"
      apply(rule order.trans) apply(rule edka3_refine)
      using Ed_Res.edka2_correct by simp
end

term Augmenting_Path_BFS.bfs

locale EdKa_Res_Bfs = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes  set_insert_time map_dom_member_time set_pick_extract_time :: "nat \<Rightarrow> nat"
    and get_succs_list_time :: nat
    and map_update_time :: "nat \<Rightarrow> nat"
    and list_append_time ::nat
    and map_lookup_time  :: "nat \<Rightarrow> nat"
    and set_empty_time set_isempty_time init_state_time :: nat
    and matrix_lookup_time matrix_set_time init_get_succs_list_time :: nat
     and init_graph :: "nat \<Rightarrow> nat"
  assumes [simp]: "\<And>c. map_lookup_time c > 0"
  assumes [simp]: "\<And>c. set_pick_extract_time c > 0"
    assumes [simp]: "matrix_lookup_time > 0"
begin
term Pre_BFS_Impl.pre_bfs_time
  definition (in -)   "shortest_path_time_aux cV cE v1 v2 v3 v4 v5  v7 v8 v9 v10 v11 v12 =
     Pre_BFS_Impl.pre_bfs_time (v1 cV) (v2 cV)  v4
                  (v5 cV) (v3 cV) v7 v8 v9 v12 cE
          + valid_PRED_impl.extract_rpath_time v10 (v11 cV) cV"

abbreviation "shortest_path_time == shortest_path_time_aux (card V) (2 * card E) set_insert_time map_dom_member_time set_pick_extract_time
        get_succs_list_time map_update_time   set_empty_time set_isempty_time init_state_time list_append_time map_lookup_time init_get_succs_list_time"

    sublocale edru: EdKa_Res_Up c s t  shortest_path_time matrix_lookup_time matrix_set_time init_graph
      apply standard  by auto

    abbreviation "resCap_cf_impl'' cf p \<equiv> edru.resCap_cf_impl' cf p"
    abbreviation "augment_cf_impl'' cf p bn \<equiv> edru.augment_cf_impl' cf p bn"

    definition "MYbfs cf ss tt = Augmenting_Path_BFS.bfs cf (set_insert_time (card (Graph.V cf))) (map_dom_member_time (card (Graph.V cf)))
                  get_succs_list_time (map_update_time (card (Graph.V cf))) (set_pick_extract_time (card (Graph.V cf)))
              list_append_time (map_lookup_time (card (Graph.V cf))) set_empty_time set_isempty_time init_state_time init_get_succs_list_time ss tt "

    subsection \<open>Refinement to use BFS\<close>

    text \<open>We refine the Edmonds-Karp algorithm to use breadth first search (BFS)\<close>
    definition "edka4 \<equiv> do {
      cf \<leftarrow> SPECT [c \<mapsto> init_graph (card V)];

      (cf,_) \<leftarrow> whileT
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          ASSERT (RGraph c s t cf);
          ASSERT ((Graph.V cf) = (Graph.V c));
          p \<leftarrow> MYbfs cf s t;
          case p of
            None \<Rightarrow> RETURNT (cf,True)
          | Some p \<Rightarrow> do {
              ASSERT (p\<noteq>[]);
              ASSERT (Graph.isShortestPath cf s p t);
              bn \<leftarrow> edru.resCap_cf_impl' cf p;
              cf \<leftarrow> edru.augment_cf_impl' cf p bn;
              ASSERT (RGraph c s t cf);
              RETURNT (cf, False)
            }
        })
        (cf,False);
      ASSERT (RGraph c s t cf);
      f \<leftarrow> RETURNT (flow_of_cf cf);
      RETURNT f
    }"

    text \<open>A shortest path can be obtained by BFS\<close>
    lemma bfs_refines_shortest_augmenting_spec: fixes cf shows
      "cf'=cf \<Longrightarrow> MYbfs cf s t \<le> \<Down>Id (edru.find_shortest_augmenting_spec_cf cf')"
      unfolding edru.find_shortest_augmenting_spec_cf apply safe
    proof (rule le_R_ASSERTI, goal_cases)
      case 1
      interpret BFS: Augmenting_Path_BFS cf "set_insert_time (card (Graph.V cf))" "map_dom_member_time (card (Graph.V cf))"
                  get_succs_list_time "map_update_time (card (Graph.V cf))" "set_pick_extract_time (card (Graph.V cf))"
              list_append_time "map_lookup_time (card (Graph.V cf))" set_empty_time set_isempty_time init_state_time
        apply standard by auto
      have -: "BFS.V = V"
        using "1" RGraph.this_loc_rpg RPreGraph.resV_netV by blast

      have "BFS.E \<subseteq> E \<union> (E)\<inverse>"
        using "1" RGraph.this_loc_rpg RPreGraph.cfE_ss_invE by blast
      then have "card (BFS.E) \<le> card (E \<union> (E)\<inverse>)"
        apply(rule card_mono[rotated]) by auto
      also have "\<dots> \<le> 2 * card E" apply(rule order.trans[OF card_Un_le])
        by simp
      finally have "card BFS.E \<le> 2 * card E" . (* TODO: get rid of the factor 2 here *)

      thm BFS.bfs_correct
      have *: "BFS.bfs_time s t \<le> shortest_path_time"
        apply(simp add: shortest_path_time_aux_def   Augmenting_Path_BFS.bfs_time_def - Augmenting_Path_BFS_def)
        apply(rule pre_bfs_time_aux_mono) by fact
      show ?case
      apply (rule order_trans) unfolding MYbfs_def
         apply (rule BFS.bfs_correct)
        using  RPreGraph.resV_netV[OF RGraph.this_loc_rpg, OF 1(2)]
      apply (simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg, OF 1(2)])
         apply (simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg, OF 1(2)])
          apply(rule SPECT_ub') using * apply (auto simp: le_fun_def)
        done
    qed

    lemma edka4_refine: "edka4 \<le> \<Down>Id edru.edka3"
      unfolding edka4_def edru.edka3_def  edru.augment_def nres_bind_assoc
      apply(refine_rcg bfs_refines_shortest_augmenting_spec)
      apply refine_dref_type
      by (simp_all add:  RPreGraph.resV_netV[OF RGraph.this_loc_rpg] )

  lemma  edka4_correct: "edka4 \<le> \<Down> Id (SPECT (emb isMaxFlow (enat (EdKa.edka_time c shortest_path_time edru.augment_with_path_time init_graph))))"
    apply(rule order.trans) apply(rule edka4_refine)
    using edru.edka3_correct by simp
end

locale Succ_Impl = Graph c for  c :: "'capacity::linordered_idom graph" +
  fixes list_append_time matrix_lookup_time :: nat
begin

    subsection \<open>Implementing the Successor Function for BFS\<close>

    text \<open>We implement the successor function in two steps.
      The first step shows how to obtain the successor function by
      filtering the list of adjacent nodes. This step contains the idea
      of the implementation. The second step is purely technical, and makes
      explicit the recursion of the filter function as a recursion combinator
      in the monad. This is required for the Sepref tool.
      \<close>

    text \<open>Note: We use @{term filter_rev} here, as it is tail-recursive,
      and we are not interested in the order of successors.\<close>
    definition (in Graph) "rg_succ am cf u \<equiv>
      filter_rev (\<lambda>v. cf (u,v) > 0) (am u)"

    lemma (in RGraph) rg_succ_ref1: "\<lbrakk>is_adj_map am\<rbrakk>
      \<Longrightarrow> (rg_succ am cf u, Graph.E cf``{u}) \<in> \<langle>Id\<rangle>list_set_rel"
      unfolding Graph.E_def
      apply (clarsimp simp: list_set_rel_def br_def rg_succ_def filter_rev_alt;
        intro conjI)
      using cfE_ss_invE resE_nonNegative
      apply (auto
        simp: is_adj_map_def less_le Graph.E_def
        simp del: cf.zero_cap_simp zero_cap_simp) []
      apply (auto simp: is_adj_map_def) []
      done

    definition (in Graph) ps_get_op :: "_ \<Rightarrow> node \<Rightarrow> node list nrest"
      where "ps_get_op am u \<equiv> ASSERT (u\<in>V) \<then> SPECT [am u\<mapsto>1]"

    definition monadic_filter_rev_aux
      :: "'a list \<Rightarrow> ('a \<Rightarrow> bool nrest) \<Rightarrow> 'a list \<Rightarrow> 'a list nrest"
    where
      "monadic_filter_rev_aux a P l \<equiv> RECT (\<lambda> D. (\<lambda>(l,a). case l of
        [] \<Rightarrow> RETURNT a
      | (v#l) \<Rightarrow> do {
          c \<leftarrow> P v;
          a \<leftarrow> (if c then
              mop_append (\<lambda>_. list_append_time) v a
            else
              RETURNT a
          );
          D (l,a)
        }
      )) (l,a)"

    lemma monadic_filter_rev_aux_rule:
      assumes P_rule: "\<And>x. x\<in>set l \<Longrightarrow> P x \<le> SPECT (emb (\<lambda>r. r=Q x) P_t)"
      shows "monadic_filter_rev_aux a P l \<le> SPECT (emb (\<lambda>r. r=filter_rev_aux a Q l) (1+ length l * (P_t+list_append_time)))"
      using assms
    proof (induction l arbitrary: a)
      case Nil
      then show ?case
      apply (unfold monadic_filter_rev_aux_def) []
      apply (subst RECT_unfold, refine_mono)
      apply (fold monadic_filter_rev_aux_def) []
      apply simp unfolding emb'_def by (auto simp: pw_le_iff)
    next
      case (Cons a l)
      show ?case
      apply (unfold monadic_filter_rev_aux_def) []
      apply (subst RECT_unfold, refine_mono)
      apply (fold monadic_filter_rev_aux_def) []
      apply(rule T_specifies_I)
        apply (vcg'\<open>-\<close> rules: mop_append Cons(2)[THEN T_specifies_rev, THEN T_conseq4]
                Cons(1)[THEN T_specifies_rev, THEN T_conseq4] )
           apply simp apply simp

        apply safe
         apply(rule Cons(1)[OF Cons(2), THEN T_specifies_rev, THEN T_conseq4] )
          apply simp
          apply(simp add: Some_le_emb'_conv Some_eq_emb'_conv)

          apply(rule Cons(1)[OF Cons(2), THEN T_specifies_rev, THEN T_conseq4] )
           apply simp
           apply(simp add: Some_le_emb'_conv Some_eq_emb'_conv)
        done
    qed

    definition "monadic_filter_rev = monadic_filter_rev_aux []"

    lemma monadic_filter_rev_rule:
      assumes "\<And>x. x\<in>set l \<Longrightarrow> P x \<le> SPECT (emb (\<lambda>r. r=Q x) P_t)"
      shows "monadic_filter_rev P l \<le> SPECT (emb (\<lambda>r. r=filter_rev Q l) (1+ length l * (P_t+list_append_time)))"
      using monadic_filter_rev_aux_rule[where a="[]"] assms
      by (auto simp: monadic_filter_rev_def filter_rev_def)

    definition "rg_succ2 am cf u \<equiv> do {
      l \<leftarrow> ps_get_op am u;
      monadic_filter_rev (\<lambda>v. do {
        x \<leftarrow> Network.cf_get c  cf (u,v) matrix_lookup_time;
        RETURNT (x>0)
      }) l
    }"

    definition "rg_succ_time len = (2+ len * (matrix_lookup_time+list_append_time))"

    lemma rg_succ_ref2:
      assumes PS: "is_adj_map am" and V: "u\<in>V"
          and RG: "RGraph c s t cf"
      shows "rg_succ2 am cf u \<le> SPECT [rg_succ am cf u \<mapsto> rg_succ_time (length (am u)) ]"
    proof -
      note n = RG[unfolded RGraph_def, THEN conjunct1]
      have "\<forall>v\<in>set (am u). valid_edge (u,v)"
        using PS V
        by (auto simp: is_adj_map_def Graph.V_def)

      thm monadic_filter_rev_rule
      thus ?thesis
        unfolding rg_succ2_def rg_succ_def ps_get_op_def
        unfolding Network.cf_get_def[OF n] apply simp
      apply(rule T_specifies_I)
        apply (vcg'\<open>-\<close> rules: monadic_filter_rev_rule[where Q="(\<lambda>v. 0 < cf (u, v))" and P_t="matrix_lookup_time", THEN T_specifies_rev, THEN T_conseq4] )
        subgoal
          apply(rule T_specifies_I)
          apply (vcg'\<open>-\<close> rules: matrix_get) by(auto simp: Some_le_emb'_conv)
        apply (simp_all add: V Some_le_emb'_conv emb_eq_Some_conv rg_succ_time_def one_enat_def)
 (*
        apply (refine_vcg monadic_filter_rev_rule[
            where Q="(\<lambda>v. 0 < cf (u, v))", THEN order_trans])
        by (vc_solve simp: V) *) done
    qed

    term RPreGraph
    lemma   rg_succ_ref:
      assumes A: "is_adj_map am"
      assumes B: "u\<in>V" and RG: "RGraph c s t cf"
      shows "rg_succ2 am cf u \<le> SPECT (emb (\<lambda>l. (l,(Graph.E cf)``{u}) \<in> \<langle>Id\<rangle>list_set_rel) (rg_succ_time (length (am u))))"

          apply(rule T_specifies_I)
      apply (vcg'\<open>-\<close> rules: rg_succ_ref2[OF A B RG, THEN T_specifies_rev, THEN T_conseq4])
      using  RGraph.rg_succ_ref1[OF RG A, of u]
      apply(auto simp add:Some_eq_emb'_conv Some_le_emb'_conv split: if_splits)
 (*
      by (auto simp: pw_le_iff refine_pw_simps) *) done

  lemma   rg_succ_ref':
      assumes A: "is_adj_map am"
      assumes B: "u\<in>V" and RG: "RGraph c s t cf"
      shows "rg_succ2 am cf u \<le> \<Down> (\<langle>nat_rel\<rangle>list_set_rel) (SPECT [Graph.E cf `` {u} \<mapsto>  (rg_succ_time (length (am u)))])"
    apply(rule order.trans[OF rg_succ_ref[OF assms]])
         apply(rule SPECT_refine)
        by (simp add: Some_eq_emb'_conv list_set_rel_def br_def  )

end

locale EdKa_Tab = Network c s t for c :: "'capacity::linordered_idom graph" and s t +
  fixes  set_insert_time map_dom_member_time set_pick_extract_time map_update_time :: "nat \<Rightarrow> nat"
    and list_append_time ::nat
    and map_lookup_time  :: "nat \<Rightarrow> nat"
    and set_empty_time set_isempty_time init_state_time :: nat
    and matrix_lookup_time matrix_set_time :: nat
    and init_graph_time :: "nat \<Rightarrow> nat"
    and init_adjm_time :: nat
  assumes [simp]: "\<And>c. map_lookup_time c > 0"
  assumes [simp]: "\<And>c. set_pick_extract_time c > 0"
    assumes [simp]: "matrix_lookup_time > 0"
begin

    subsection \<open>Adding Tabulation of Input\<close>
    text \<open>
      Next, we add functions that will be refined to tabulate the input of
      the algorithm, i.e., the network's capacity matrix and adjacency map,
      into efficient representations.
      The capacity matrix is tabulated to give the initial residual graph,
      and the adjacency map is tabulated for faster access.

      Note, on the abstract level, the tabulation functions are just identity,
      and merely serve as marker constants for implementation.
      \<close>
    definition (in Network) init_cf :: "(nat \<Rightarrow> nat) \<Rightarrow> 'capacity graph nrest"
      \<comment> \<open>Initialization of residual graph from network\<close>
      where "init_cf init_graph_time \<equiv> SPECT [ c \<mapsto> init_graph_time (card V) ]"
    definition (in Network)  init_ps :: "nat \<Rightarrow> (node \<Rightarrow> node list) \<Rightarrow> _"
      \<comment> \<open>Initialization of adjacency map\<close>
      where "init_ps init_adjm_time am  \<equiv> ASSERT (is_adj_map am) \<then> SPECT [ am \<mapsto> init_adjm_time ]"

    definition (in Network)  compute_rflow :: "'capacity graph \<Rightarrow> 'capacity flow nrest"
      \<comment> \<open>Extraction of result flow from residual graph\<close>
      where
      "compute_rflow cf \<equiv> ASSERT (RGraph c s t cf) \<then> RETURNT (flow_of_cf cf)"

    definition (in -) get_succs_list_time_aux where
      "get_succs_list_time_aux matrix_lookup_time list_append_time =  (matrix_lookup_time+list_append_time)"

    abbreviation "get_succs_list_time   \<equiv> get_succs_list_time_aux matrix_lookup_time list_append_time "

    term Augmenting_Path_BFS.bfs2

    definition "MYrg_succ2 am cf u = Succ_Impl.rg_succ2 c list_append_time matrix_lookup_time am cf u"

definition (in -) "bfs2_op_aux c s t
set_insert_time
  map_dom_member_time

  map_update_time
  set_pick_time
  list_append_time
  map_lookup_time
  set_empty_time
  set_isempty_time
  matrix_lookup_time

am cf init_state \<equiv>
Augmenting_Path_BFS.bfs2 cf set_insert_time map_dom_member_time   map_update_time set_pick_time
          list_append_time map_lookup_time set_empty_time set_isempty_time   (Succ_Impl.rg_succ2  c list_append_time matrix_lookup_time am cf) init_state  s t  "

abbreviation "bfs2_op am cf init_state \<equiv> bfs2_op_aux c s t (set_insert_time (card (Graph.V cf)))
  (map_dom_member_time (card (Graph.V cf)))
  (map_update_time (card (Graph.V cf)))
  (set_pick_extract_time (card (Graph.V cf)))
  list_append_time
  (map_lookup_time (card (Graph.V cf)))
  set_empty_time
  set_isempty_time
  matrix_lookup_time am cf init_state"

     text \<open>We split the algorithm into a tabulation function, and the
      running of the actual algorithm:\<close>
    definition (in Network) "edka5_tabulate init_graph_time init_adjm_time am  \<equiv> do {
      cf \<leftarrow> init_cf init_graph_time;
      am \<leftarrow> init_ps init_adjm_time am;
      RETURNT (cf,am)
    }"

abbreviation "prepare_time == (\<lambda>n. init_graph_time n + init_adjm_time)"

    sublocale edka: EdKa_Res_Bfs c s t set_insert_time map_dom_member_time set_pick_extract_time
      get_succs_list_time
      map_update_time
      list_append_time map_lookup_time set_empty_time  set_isempty_time init_state_time
      matrix_lookup_time matrix_set_time 2 prepare_time
      apply(standard) by auto

  lemma pff: "RGraph c s t cf \<Longrightarrow> (Graph.V cf) = (Graph.V c)"
    using RGraph.this_loc_rpg RPreGraph.resV_netV by fastforce

    definition "edka5_run cf am init_state \<equiv> do {
      (cf,_) \<leftarrow> whileT
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          ASSERT (RGraph c s t cf);
          ASSERT ((Graph.V cf) = (Graph.V c));
          p \<leftarrow> bfs2_op am cf init_state;
          case p of
            None \<Rightarrow> RETURNT (cf,True)
          | Some p \<Rightarrow> do {
              ASSERT (p\<noteq>[]);
              ASSERT (Graph.isShortestPath cf s p t);
              bn \<leftarrow> edka.resCap_cf_impl'' cf p;
              cf \<leftarrow> edka.augment_cf_impl'' cf p bn;
              ASSERT (RGraph c s t cf);
              RETURNT (cf, False)
            }
        })
        (cf,False);
      f \<leftarrow> compute_rflow cf;
      RETURNT f
    }"

    definition "edka5 am init_state   \<equiv> do {
      (cf,am) \<leftarrow> edka5_tabulate init_graph_time init_adjm_time am ;
      edka5_run cf am init_state
    }"

lemma k: "((a, b), aa, ba) \<in> Id \<times>\<^sub>r bool_rel \<Longrightarrow> a=aa" by auto

lemma is_adj_mapD_V: "\<And>am u. is_adj_map am \<Longrightarrow> u \<in> V  \<Longrightarrow> distinct (am u) \<and> set (am u) \<subseteq> V"
  unfolding is_adj_map_def unfolding V_def by auto

lemma is_adj_map_app_le_V: "is_adj_map am \<Longrightarrow> u \<in> V  \<Longrightarrow> length (am u) \<le> card V"
  apply(auto dest!: is_adj_mapD_V)
    apply(rule order.trans[where b="card (set (am u))"]) using distinct_card[symmetric]
  apply fastforce apply(rule card_mono)
  by auto

lemma (in RPreGraph) E_is_cfE: "E \<union> E\<inverse> = cf.E \<union> cf.E\<inverse>"
  using E_ss_cfinvE cfE_ss_invE by blast

lemma (in RPreGraph) hh: assumes "is_adj_map am"
        "u \<in> V"
      shows "length (am u) \<le> card (cf.E `` {u}) + card (cf.E\<inverse> `` {u})"
proof -
  have *: "(E``{u} \<union> E\<inverse>``{u}) = (cf.E)``{u} \<union> cf.E\<inverse>``{u}" using E_is_cfE by auto

  from assms(1) have [simp]: "distinct (am u)" and "set (am u) = E``{u} \<union> E\<inverse>``{u}" by(auto simp: is_adj_map_def)
  then have "card (E``{u} \<union> E\<inverse>``{u}) = card (set (am u))" by simp
  also have "\<dots> = length (am u)" by(auto intro: distinct_card)
  finally have "length (am u) = card (E``{u} \<union> E\<inverse>``{u})" by simp
  also have "\<dots> = card ((cf.E)``{u} \<union> cf.E\<inverse>``{u})" using * by auto
  also have "\<dots> <= card ((cf.E)``{u}) + card ( cf.E\<inverse>``{u})" by(rule   card_Un_le)
  finally show ?thesis .
qed

lemma (in Graph) hh: assumes "is_adj_map am"
        "RGraph c s t cf"
        "u \<in> V"
      shows "length (am u) \<le> card (Graph.E cf `` {u}) + card ((Graph.E cf)\<inverse> `` {u})"
proof -
  have "RPreGraph c s t cf" using assms(2) RGraph.this_loc_rpg by auto
  from RPreGraph.hh[OF this] assms(1,3) show ?thesis by blast
qed

  abbreviation "augment am R \<equiv> {((cc, cam), ac). (cc, ac)\<in>R \<and> cam = am}"

  lemma augment_conv: "\<Down> (augment am Id) (SPECT [a \<mapsto> tt]) = (SPECT [ (a,am) \<mapsto> tt])"
    by (auto simp: pw_eq_iff bot_option_def conc_fun_def dest: Sup_Some )

  (* augment the initialization for an adjacency list *)
  lemma edka_tab: "is_adj_map am \<Longrightarrow> edka5_tabulate init_graph_time init_adjm_time am \<le> \<Down> (augment am Id) (SPECT [ c \<mapsto> enat (init_graph_time (card V) + init_adjm_time)])"
    unfolding edka5_tabulate_def init_cf_def init_ps_def augment_conv
        apply(rule T_specifies_I)
        apply(vcg'\<open>-\<close>  )  by auto

lemma rg_succ2_impl: "is_adj_map am \<Longrightarrow>
    RGraph c s t cf \<Longrightarrow>
    (ui, u) \<in> nat_rel \<Longrightarrow>
    u \<in> Graph.V cf \<Longrightarrow>
    Succ_Impl.rg_succ2 c list_append_time matrix_lookup_time am cf ui
    \<le> \<Down> (\<langle>nat_rel\<rangle>list_set_rel) (SPECT [Graph.E cf `` {u} \<mapsto> enat (2 + (card (Graph.E cf `` {u}) + card ((Graph.E cf)\<inverse> `` {u})) * get_succs_list_time)])"
  unfolding  MYrg_succ2_def
  apply(rule order.trans)
   apply(rule Succ_Impl.rg_succ_ref') apply simp
    apply(simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg])
   apply simp
  apply(rule nrest_Rel_mono)
  apply (auto simp add: le_fun_def get_succs_list_time_aux_def Succ_Impl.rg_succ_time_def
      RPreGraph.resV_netV[OF RGraph.this_loc_rpg] is_adj_map_app_le_V)
  subgoal apply(subst Graph.hh) by auto
  done

lemma edka5_refine:
  assumes "is_adj_map am"
    and init_state_impl:
      "\<And>src. init_state src \<le> \<Down>Id (SPECT [ (False,[src\<mapsto>src],{src},{},0::nat) \<mapsto> init_state_time ])"
  shows "is_adj_map am \<Longrightarrow> edka5 am init_state   \<le> \<Down>Id edka.edka4"
  unfolding edka5_def   edka5_run_def
    edka.edka4_def  compute_rflow_def
    Let_def bfs2_op_aux_def  edka.MYbfs_def
  apply(refine_rcg edka_tab Augmenting_Path_BFS.bfs2_refine )
  apply refine_dref_type
  apply simp_all
  apply(rule R_intro)
  apply(rule Augmenting_Path_BFS.bfs2_refine)
    apply(simp add: Augmenting_Path_BFS_def)
  subgoal
    by (refine_rcg rg_succ2_impl)
  subgoal
    apply(rule R_intro)
    by (refine_rcg init_state_impl)
  done

       (*
      apply refine_rcg
      apply refine_dref_type
      apply (vc_solve simp: )
      apply (rule refine_IdD)
      apply (rule Graph.bfs2_refine)
      apply (simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg])
      apply (simp add: RGraph.rg_succ_ref)
      done *)

    thm edka.edka4_correct
  lemma  edka5_correct: "\<lbrakk>is_adj_map am; \<And>src. init_state src \<le> SPECT [ (False,[src\<mapsto>src],{src},{},0::nat) \<mapsto> init_state_time] \<rbrakk> \<Longrightarrow> edka5 am init_state \<le> \<Down> Id (SPECT (emb isMaxFlow (enat (EdKa.edka_time c edka.shortest_path_time (EdKa_Res_Up.augment_with_path_time c matrix_lookup_time matrix_set_time) prepare_time))))"
    apply(rule order.trans) apply(rule edka5_refine)
    using edka.edka4_correct by simp_all

end
end


(*  Title:      ZF/IMP/Equiv.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section {* Equivalence *}

theory Equiv imports Denotation Com begin

lemma aexp_iff [rule_format]:
  "[| a \<in> aexp; sigma: loc -> nat |]
    ==> \<forall>n. <a,sigma> -a-> n \<longleftrightarrow> A(a,sigma) = n"
  apply (erule aexp.induct)
     apply (force intro!: evala.intros)+
  done

declare aexp_iff [THEN iffD1, simp]
        aexp_iff [THEN iffD2, intro!]

inductive_cases [elim!]:
  "<true,sigma> -b-> x"
  "<false,sigma> -b-> x"
  "<ROp(f,a0,a1),sigma> -b-> x"
  "<noti(b),sigma> -b-> x"
  "<b0 andi b1,sigma> -b-> x"
  "<b0 ori b1,sigma> -b-> x"

lemma bexp_iff [rule_format]:
  "[| b \<in> bexp; sigma: loc -> nat |]
    ==> \<forall>w. <b,sigma> -b-> w \<longleftrightarrow> B(b,sigma) = w"
  apply (erule bexp.induct)
  apply (auto intro!: evalb.intros)
  done

declare bexp_iff [THEN iffD1, simp]
        bexp_iff [THEN iffD2, intro!]

lemma com1: "<c,sigma> -c-> sigma' ==> <sigma,sigma'> \<in> C(c)"
  apply (erule evalc.induct)
        apply (simp_all (no_asm_simp))
     txt {* @{text assign} *}
     apply (simp add: update_type)
    txt {* @{text comp} *}
    apply fast
   txt {* @{text while} *}
   apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
   apply (simp add: Gamma_def)
  txt {* recursive case of @{text while} *}
  apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
  apply (auto simp add: Gamma_def)
  done

declare B_type [intro!] A_type [intro!]
declare evalc.intros [intro]

lemma com2 [rule_format]: "c \<in> com ==> \<forall>x \<in> C(c). <c,fst(x)> -c-> snd(x)"
  apply (erule com.induct)
      txt {* @{text skip} *}
      apply force
     txt {* @{text assign} *}
     apply force
    txt {* @{text comp} *}
    apply force
   txt {* @{text while} *}
   apply safe
   apply simp_all
   apply (frule Gamma_bnd_mono [OF C_subset], erule Fixedpt.induct, assumption)
   apply (unfold Gamma_def)
   apply force
  txt {* @{text "if"} *}
  apply auto
  done

subsection {* Main theorem *}

theorem com_equivalence:
    "c \<in> com ==> C(c) = {io \<in> (loc->nat) \<times> (loc->nat). <c,fst(io)> -c-> snd(io)}"
  by (force intro: C_subset [THEN subsetD] elim: com2 dest: com1)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
License: LGPL
*)

section \<open>Computing Minimal Complete Sets of Solutions\<close>

theory Algorithm
  imports Simple_Algorithm
begin

(*TODO: move*)
lemma all_Suc_le_conv: "(\<forall>i\<le>Suc n. P i) \<longleftrightarrow> P 0 \<and> (\<forall>i\<le>n. P (Suc i))"
  by (metis less_Suc_eq_0_disj nat_less_le order_refl)

(*TODO: move*)
lemma concat_map_filter_filter:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> Q x \<Longrightarrow> filter P (f x) = []"
  shows "concat (map (filter P \<circ> f) (filter Q xs)) = concat (map (filter P \<circ> f) xs)"
  using assms by (induct xs) simp_all

(*TODO: move*)
lemma filter_pairs_conj:
  "filter (\<lambda>(x, y). P x y \<and> Q y) xs = filter (\<lambda>(x, y). P x y) (filter (Q \<circ> snd) xs)"
  by (induct xs) auto

(*TODO: move*)
lemma concat_map_filter:
  "concat (map f (filter P xs)) = concat (map (\<lambda>x. if P x then f x else []) xs)"
  by (induct xs) simp_all

fun alls
  where
    "alls B [] = [([], 0)]"
  | "alls B (a # as) = [(x # xs, s + a * x). (xs, s) \<leftarrow> alls B as, x \<leftarrow> [0 ..< B + 1]]"

lemma alls_ne [simp]:
  "alls B as \<noteq> []"
  by (induct as)
    (auto, metis (no_types, lifting) append_is_Nil_conv case_prod_conv list.set_intros(1)
     neq_Nil_conv old.prod.exhaust)

lemma set_alls: "set (alls B a) =
  {(x, s). length x = length a \<and> (\<forall>i<length a. x ! i \<le> B) \<and> s = a \<bullet> x}"
    (is "?L a = ?R a")
proof
  show "?L a \<subseteq> ?R a" by (induct a) (auto simp: nth_Cons split: nat.splits)
next
  show "?R a \<subseteq> ?L a"
  proof (induct a)
    case (Cons a as)
    show ?case
    proof
      fix xs' assume "xs' \<in> ?R (a # as)"
      then obtain x and xs where [simp]: "xs' = (x # xs, (a # as) \<bullet> (x # xs))"
        and "length as = length xs"
        and B: "x \<le> B" "\<forall>i<length as. xs ! i \<le> B"
        by (cases xs', case_tac a) (auto simp: All_less_Suc2)
      then have "(xs, as \<bullet> xs) \<in> ?L as" using Cons by auto
      then show "xs' \<in> ?L (a # as)"
        using B
        apply auto
        apply (rule bexI [of _ "(xs, as \<bullet> xs)"])
         apply auto
        done
    qed
  qed auto
qed

lemma alls_nth0 [simp]: "alls A as ! 0 = (zeroes (length as), 0)"
  by (induct as) (auto simp: nth_append concat_map_nth0)

lemma alls_Cons_tl_conv: "alls A as = (zeroes (length as), 0) # tl (alls A as)"
  by (rule nth_equalityI) (auto simp: nth_Cons nth_tl split: nat.splits)

lemma sorted_wrt_alls:
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x) (map fst (alls B xs))"
  by (induct xs) (auto simp: map_concat rlex_Cons sorted_wrt_append
      intro!: sorted_wrt_concat_map sorted_wrt_map_mono [of "(<)"])

definition "alls2 A B a b = [(xs, ys). ys \<leftarrow> alls B b, xs \<leftarrow> alls A a]"

lemma alls2_ne [simp]:
  "alls2 A B a b \<noteq> []"
  by (auto simp: alls2_def) (metis alls_ne list.set_intros(1) neq_Nil_conv surj_pair)

lemma set_alls2:
  "set (alls2 A B a b) = {((x, s), (y, t)). length x = length a \<and> length y = length b \<and>
    (\<forall>i<length a. x ! i \<le> A) \<and> (\<forall>j<length b. y ! j \<le> B) \<and> s = a \<bullet> x \<and> t = b \<bullet> y}"
  by (auto simp: alls2_def set_alls)

lemma alls2_nth0 [simp]: "alls2 A B as bs ! 0 = ((zeroes (length as), 0), (zeroes (length bs), 0))"
  by (auto simp: alls2_def concat_map_nth0)

lemma alls2_Cons_tl_conv: "alls2 A B as bs =
  ((zeroes (length as), 0), (zeroes (length bs), 0)) # tl (alls2 A B as bs)"
  apply (rule nth_equalityI)
   apply (auto simp: alls2_def nth_Cons nth_tl length_concat concat_map_nth0 split: nat.splits)
  apply (cases "alls B bs"; simp)
  done

abbreviation gen2
  where
    "gen2 A B a b \<equiv> map (\<lambda>(x, y). (fst x, fst y)) (alls2 A B a b)"

lemma sorted_wrt_gen2:
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (gen2 A B a b)"
  apply (rule sorted_wrt_map_mono [of "\<lambda>(x, y) (u, v). (fst x, fst y) <\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2 (fst u, fst v)"])
   apply (auto simp: alls2_def map_concat)
  apply (fold rlex2.simps)
  apply (rule sorted_wrt_concat_map_map)
     apply (rule sorted_wrt_map_distr, rule sorted_wrt_alls)
    apply (rule sorted_wrt_map_distr, rule sorted_wrt_alls)
   apply (auto simp: rlex_def set_alls intro: lex_append_leftI lex_append_rightI)
  done

definition generate'
  where
    "generate' A B a b = tl (map (\<lambda>(x, y). (fst x, fst y)) (alls2 A B a b))"

lemma sorted_wrt_generate':
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (generate' A B a b)"
  by (auto simp: generate'_def sorted_wrt_gen2 sorted_wrt_tl)

lemma gen2_nth0 [simp]:
  "gen2 A B a b ! 0 = (zeroes (length a), zeroes (length b))"
  by auto

lemma gen2_ne [simp, intro]: "gen2 m n b c \<noteq> []" by auto

lemma in_generate': "x \<in> set (generate' m n c b) \<Longrightarrow> x \<in> set (gen2 m n c b)"
  unfolding generate'_def by (rule list.set_sel) simp

definition "cond_cons P = (\<lambda>(ys, s). case ys of [] \<Rightarrow> True | ys \<Rightarrow> P ys s)"

lemma cond_cons_simp [simp]:
  "cond_cons P ([], s) = True"
  "cond_cons P (x # xs, s) = P (x # xs) s"
  by (auto simp: cond_cons_def)

fun suffs
  where
    "suffs P as (xs, s) \<longleftrightarrow>
      length xs = length as \<and>
      s = as \<bullet> xs \<and>
      (\<forall>i\<le>length xs. cond_cons P (drop i xs, drop i as \<bullet> drop i xs))"
declare suffs.simps [simp del]

lemma suffs_Nil [simp]: "suffs P [] ([], s) \<longleftrightarrow> s = 0"
  by (auto simp: suffs.simps)

lemma suffs_Cons:
  "suffs P (a # as) (x # xs, s) \<longleftrightarrow>
    s = a * x + as \<bullet> xs \<and> cond_cons P (x # xs, s) \<and> suffs P as (xs, as \<bullet> xs)"
  apply (auto simp: suffs.simps cond_cons_def split: list.splits)
    apply force
   apply (metis Suc_le_mono drop_Suc_Cons)
  by (metis One_nat_def Suc_le_mono Suc_pred dotprod_Cons drop_Cons' le_0_eq not_le_imp_less)

subsection \<open>The Algorithm\<close>

fun maxne0_impl
  where
    "maxne0_impl [] a = 0"
  | "maxne0_impl x [] = 0"
  | "maxne0_impl (x#xs) (a#as) = (if x > 0 then max a (maxne0_impl xs as) else maxne0_impl xs as)"

lemma maxne0_impl:
  assumes "length x = length a"
  shows "maxne0_impl x a = maxne0 x a"
  using assms by (induct x a rule: list_induct2) (auto)

context
  fixes a b :: "nat list"
begin

definition special_solutions :: "(nat list \<times> nat list) list"
  where
    "special_solutions = [sij a b i j . i \<leftarrow> [0 ..< length a], j \<leftarrow> [0 ..< length b]]"

definition big_e :: "nat list \<Rightarrow> nat \<Rightarrow> nat list"
  where
    "big_e x j = map (\<lambda>i. eij a b i j - 1) (filter (\<lambda>i. x ! i \<ge> dij a b i j) [0 ..< length x])"

definition big_d :: "nat list \<Rightarrow> nat \<Rightarrow> nat list"
  where
    "big_d y i = map (\<lambda>j. dij a b i j - 1) (filter (\<lambda>j. y ! j \<ge> eij a b i j) [0 ..< length y])"

definition big_d' :: "nat list \<Rightarrow> nat \<Rightarrow> nat list"
  where
    "big_d' y i =
      (let l = length y; n = length b in
      if l > n then [] else
      (let k = n - l in
      map (\<lambda>j. dij a b i (j + k) - 1) (filter (\<lambda>j. y ! j \<ge> eij a b i (j + k)) [0 ..< length y])))"

definition max_y_impl :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_y_impl x j =
      (if j < length b \<and> big_e x j \<noteq> [] then Min (set (big_e x j))
      else Max (set a))"

definition max_x_impl :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_x_impl y i =
      (if i < length a \<and> big_d y i \<noteq> [] then Min (set (big_d y i))
      else Max (set b))"

definition max_x_impl' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_x_impl' y i =
      (if i < length a \<and> big_d' y i \<noteq> [] then Min (set (big_d' y i))
      else Max (set b))"

definition cond_a :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "cond_a xs ys \<longleftrightarrow> (\<forall>x\<in>set xs. x \<le> maxne0 ys b)"

definition cond_b :: "nat list \<Rightarrow> bool"
  where
    "cond_b xs \<longleftrightarrow> (\<forall>k\<le>length a.
      take k a \<bullet> take k xs \<le> b \<bullet> (map (max_y_impl (take k xs)) [0 ..< length b]))"

definition boundr_impl :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "boundr_impl x y \<longleftrightarrow> (\<forall>j<length b. y ! j \<le> max_y_impl x j)"

definition cond_d :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "cond_d xs ys \<longleftrightarrow> (\<forall>l\<le>length b. take l b \<bullet> take l ys \<le> a \<bullet> xs)"

definition subdprodr_impl :: "nat list \<Rightarrow> bool"
  where
    "subdprodr_impl ys \<longleftrightarrow> (\<forall>l\<le>length b.
      take l b \<bullet> take l ys \<le> a \<bullet> map (max_x_impl (take l ys)) [0 ..< length a])"

definition subdprodl_impl :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "subdprodl_impl x y \<longleftrightarrow> (\<forall>k\<le>length a. take k a \<bullet> take k x \<le> b \<bullet> y)"

definition "boundl_impl x y \<longleftrightarrow> (\<forall>i<length a. x ! i \<le> max_x_impl y i)"

definition static_bounds
  where
    "static_bounds x y \<longleftrightarrow>
      (let mx = maxne0_impl y b; my = maxne0_impl x a in
      (\<forall>x\<in>set x. x \<le> mx) \<and> (\<forall>y\<in>set y. y \<le> my))"

definition "check_cond =
  (\<lambda>(x, y). static_bounds x y \<and> a \<bullet> x = b \<bullet> y \<and> boundr_impl x y \<and> subdprodl_impl x y \<and> subdprodr_impl y)"

definition "check' = filter check_cond"

definition "non_special_solutions =
  (let A = Max (set b); B = Max (set a)
  in minimize (check' (generate' A B a b)))"

definition "solve = special_solutions @ non_special_solutions"

end

lemma sorted_wrt_check_generate':
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (check' a b (generate' A B a b))"
  by (auto simp: check'_def intro!: sorted_wrt_filter sorted_wrt_generate' sorted_wrt_tl)

lemma big_e:
  "set (big_e a b xs j) = hlde_ops.Ej a b j xs"
  by (auto simp: hlde_ops.Ej_def big_e_def)

lemma big_d:
  "set (big_d a b ys i) = hlde_ops.Di a b i ys"
  by (auto simp: hlde_ops.Di_def big_d_def)

lemma big_d':
  "length ys \<le> length b \<Longrightarrow> set (big_d' a b ys i) = hlde_ops.Di' a b i ys"
  by (auto simp: hlde_ops.Di'_def big_d'_def Let_def)

lemma max_y_impl:
  "max_y_impl a b x j = hlde_ops.max_y a b x j"
  by (simp add: max_y_impl_def big_e hlde_ops.max_y_def set_empty [symmetric])

lemma max_x_impl:
  "max_x_impl a b y i = hlde_ops.max_x a b y i"
  by (simp add: max_x_impl_def big_d hlde_ops.max_x_def set_empty [symmetric])

lemma max_x_impl':
  assumes "length y \<le> length b"
  shows "max_x_impl' a b y i = hlde_ops.max_x' a b y i"
  by (simp add: max_x_impl'_def big_d' [OF assms] hlde_ops.max_x'_def set_empty [symmetric])

lemma (in hlde) cond_a [simp]: "cond_a b x y = cond_A x y"
  by (simp add: cond_a_def cond_A_def)

lemma (in hlde) cond_b [simp]: "cond_b a b x = cond_B x"
  using max_y_impl by (auto simp: cond_b_def cond_B_def) presburger+

lemma (in hlde) boundr_impl [simp]: "boundr_impl a b x y = boundr x y"
  by (simp add: boundr_impl_def boundr_def max_y_impl)

lemma (in hlde) cond_d [simp]: "cond_d a b x y = cond_D x y"
  by (simp add: cond_d_def cond_D_def)

lemma (in hlde) subdprodr_impl [simp]: "subdprodr_impl a b y = subdprodr y"
  using max_x_impl by (auto simp: subdprodr_impl_def subdprodr_def) presburger+

lemma (in hlde) subdprodl_impl [simp]: "subdprodl_impl a b x y = subdprodl x y"
  by (simp add: subdprodl_impl_def subdprodl_def)

lemma (in hlde) cond_bound_impl [simp]: "boundl_impl a b x y = boundl x y"
  by (simp add: boundl_impl_def boundl_def max_x_impl)

lemma (in hlde) check [simp]:
  "check' a b =
    filter (\<lambda>(x, y). static_bounds a b x y \<and> a \<bullet> x = b \<bullet> y \<and> boundr x y \<and>
    subdprodl x y \<and>
    subdprodr y)"
  by (simp add: check'_def check_cond_def)

text \<open>
  conditions B, C, and D from Huet as well as "subdprodr" and "subdprodl" are
  preserved by smaller solutions
\<close>
lemma (in hlde) le_imp_conds:
  assumes le: "u \<le>\<^sub>v x" "v \<le>\<^sub>v y"
    and len: "length x = m" "length y = n"
  shows "cond_B x \<Longrightarrow> cond_B u"
    and "boundr x y \<Longrightarrow> boundr u v"
    and "a \<bullet> u = b \<bullet> v \<Longrightarrow> cond_D x y \<Longrightarrow> cond_D u v"
    and "a \<bullet> u = b \<bullet> v \<Longrightarrow> subdprodl x y \<Longrightarrow> subdprodl u v"
    and "subdprodr y \<Longrightarrow> subdprodr v"
proof -
  assume B: "cond_B x"
  have "length u = m" using len and le by (auto)
  show "cond_B u"
  proof (unfold cond_B_def, intro allI impI)
    fix k
    assume k: "k \<le> m"
    moreover have *: "take k u \<le>\<^sub>v take k x" if "k \<le> m" for k
      using le and that by (intro le_take) (auto simp: len)
    ultimately have "take k a \<bullet> take k u \<le> take k a \<bullet> take k x"
      by (intro dotprod_le_right) (auto simp: len)
    also have "\<dots> \<le> b \<bullet> map (max_y (take k x)) [0..<n]"
      using k and B by (auto simp: cond_B_def)
    also have "\<dots> \<le> b \<bullet> map (max_y (take k u)) [0..<n]"
      using le_imp_max_y_ge [OF * [OF k]]
      using k by (auto simp: len intro!: dotprod_le_right less_eqI)
    finally show "take k a \<bullet> take k u \<le> b \<bullet> map (max_y (take k u)) [0..<n]" .
  qed
next
  assume subdprodr: "subdprodr y"
  have "length v = n" using len and le by (auto)
  show "subdprodr v"
  proof (unfold subdprodr_def, intro allI impI)
    fix l
    assume l: "l \<le> n"
    moreover have *: "take l v \<le>\<^sub>v take l y" if "l \<le> n" for l
      using le and that by (intro le_take) (auto simp: len)
    ultimately have "take l b \<bullet> take l v \<le> take l b \<bullet> take l y"
      by (intro dotprod_le_right) (auto simp: len)
    also have "\<dots> \<le> a \<bullet> map (max_x (take l y)) [0..<m]"
      using l and subdprodr by (auto simp: subdprodr_def)
    also have "\<dots> \<le> a \<bullet> map (max_x (take l v)) [0..<m]"
      using le_imp_max_x_ge [OF * [OF l]]
      using l by (auto simp: len intro!: dotprod_le_right less_eqI)
    finally show "take l b \<bullet> take l v \<le> a \<bullet> map (max_x (take l v)) [0..<m]" .
  qed
next
  assume C: "boundr x y"
  show "boundr u v"
    using le_imp_max_y_ge [OF \<open>u \<le>\<^sub>v x\<close>] and C and le
    by (auto simp: boundr_def len less_eq_def) (meson order_trans)
next
  assume "a \<bullet> u = b \<bullet> v" and "cond_D x y"
  then show "cond_D u v"
    using le by (auto simp: cond_D_def len le_length intro: dotprod_le_take)
next
  assume "a \<bullet> u = b \<bullet> v" and "subdprodl x y"
  then show "subdprodl u v"
    using le by (metis subdprodl_def dotprod_le_take le_length len(1))
qed

lemma (in hlde) special_solutions [simp]:
  shows "set (special_solutions a b) = Special_Solutions"
proof -
  have "set (special_solutions a b) \<subseteq> Special_Solutions"
    by (auto simp: Special_Solutions_def special_solutions_def) (blast)
  moreover have "Special_Solutions \<subseteq> set (special_solutions a b)"
    by (auto simp: Special_Solutions_def special_solutions_def)
  ultimately show ?thesis ..
qed

lemma set_gen2:
  "set (gen2 A B a b) = {(x, y). x \<le>\<^sub>v replicate (length a) A \<and> y \<le>\<^sub>v replicate (length b) B}"
  (is "?L = ?R")
proof (intro equalityI subrelI)
  fix xs ys assume "(xs, ys) \<in> ?R"
  then have "\<forall>x\<in>set xs. x \<le> A" and "\<forall>y\<in>set ys. y \<le> B"
    and "length xs = length a" and "length ys = length b"
    by (auto simp: less_eq_def in_set_conv_nth)
  then have "((xs, a \<bullet> xs), (ys, b \<bullet> ys)) \<in> set (alls2 A B a b)" by (auto simp: set_alls2)
  then have "(\<lambda>(x, y). (fst x, fst y)) ((xs, a \<bullet> xs), (ys, b \<bullet> ys)) \<in> (\<lambda>(x, y). (fst x, fst y)) ` set (alls2 A B a b)"
    by (intro imageI)
  then show "(xs, ys) \<in> ?L" by simp
qed (auto simp: less_eq_def set_alls2)

lemma set_gen2':
  "(\<lambda>(x, y). (fst x, fst y)) ` set (alls2 A B a b) =
    {(x, y). x \<le>\<^sub>v replicate (length a) A \<and> y \<le>\<^sub>v replicate (length b) B}"
  using set_gen2 by simp

lemma (in hlde) in_non_special_solutions:
  assumes "(x, y) \<in> set (non_special_solutions a b)"
  shows "(x, y) \<in> Solutions"
  using assms
  by (auto dest!: minimize_wrtD in_generate'
    simp: non_special_solutions_def in_Solutions_iff minimize_def set_alls2)

lemma generate_unique:
  assumes "i < j"
    and "j < length (generate A B a b)"
  shows "generate A B a b ! i \<noteq> generate A B a b ! j"
  using sorted_wrt_nth_less [OF sorted_wrt_generate assms]
  by (auto simp: rlex2_irrefl)

lemma gen2_unique:
  assumes "i < j"
    and "j < length (gen2 A B a b)"
  shows "gen2 A B a b ! i \<noteq> gen2 A B a b ! j"
  using sorted_wrt_nth_less [OF sorted_wrt_gen2 assms]
  by (auto simp: rlex2_irrefl)

lemma zeroes_ni_generate':
  "(zeroes (length a), zeroes (length b)) \<notin> set (generate' A B a b)"
proof -
  have "gen2 A B a b ! 0 = (zeroes (length a), zeroes (length b))" by (auto)
  with gen2_unique [of 0 _ A B a b] show ?thesis
    by (auto simp: in_set_conv_nth nth_tl generate'_def)
      (metis One_nat_def Suc_eq_plus1 less_diff_conv zero_less_Suc)
qed

lemma set_generate':
  "set (generate' A B a b) =
    {(x, y). (x, y) \<noteq> (zeroes (length a), zeroes (length b)) \<and> (x, y) \<in> set (gen2 A B a b)}"
proof
  show "set (generate' A B a b)
        \<subseteq> {(x, y).(x, y) \<noteq> (zeroes (length a), zeroes (length b)) \<and> (x, y) \<in> set (gen2 A B a b)}"
    using in_generate' and mem_Collect_eq and zeroes_ni_generate' by (auto)
next
  have "(zeroes (length a), zeroes (length b)) = hd (gen2 A B a b)"
    by (simp add: hd_conv_nth)
  moreover have "set (gen2 A B a b) = set (tl (gen2 A B a b)) \<union> {(zeroes (length a), zeroes (length b))}"
    by (metis Un_empty_right Un_insert_right gen2_ne calculation list.exhaust_sel list.simps(15))
  ultimately show " {(x, y). (x, y) \<noteq> (zeroes (length a), zeroes (length b)) \<and> (x, y) \<in> set (gen2 A B a b)}
        \<subseteq> set (generate' A B a b)"
    unfolding generate'_def by blast
qed

lemma set_generate'':
  "set (generate' A B a b) =
  {(x, y). (x, y) \<noteq> (zeroes (length a), zeroes (length b)) \<and> x \<le>\<^sub>v replicate (length a) A \<and> y \<le>\<^sub>v replicate (length b) B}"
  by (simp add: set_generate' set_gen2')

lemma (in hlde) zeroes_ni_non_special_solutions:
  shows "(zeroes m, zeroes n) \<notin> set (non_special_solutions a b)"
proof -
  define All_lex where
    All_lex: "All_lex = gen2 (Max (set b)) (Max (set a)) a b"
  define z where z: "z = (zeroes m, zeroes n)"
  have "set (non_special_solutions a b) \<subseteq> set (tl (All_lex))"
    by (auto simp: All_lex generate'_def non_special_solutions_def minimize_def dest: minimize_wrtD)
  moreover have "z \<notin> set (tl (All_lex))"
    using zeroes_ni_generate' All_lex z by (auto simp: generate'_def)
  ultimately show ?thesis
    using z by blast
qed

subsubsection \<open>Correctness: \<open>solve\<close> generates only minimal solutions.\<close>

lemma (in hlde) solve_subset_Minimal_Solutions:
  shows "set (solve a b) \<subseteq> Minimal_Solutions"
proof (rule subrelI)
  let ?a = "Max (set a)" and ?b = "Max (set b)"
  fix x y
  assume ass: "(x, y) \<in> set (solve a b)"
  then consider "(x, y) \<in> set (special_solutions a b)" | "(x, y) \<in> set (non_special_solutions a b)"
    unfolding solve_def and set_append by blast
  then show "(x, y) \<in> Minimal_Solutions"
  proof (cases)
    case 1
    then have "(x, y) \<in> Special_Solutions"
      unfolding special_solutions .
    then show ?thesis
      by (simp add: Special_Solutions_in_Minimal_Solutions)
  next
    let ?xs = "[(x, y) \<leftarrow> generate' ?b ?a a b.
      static_bounds a b x y \<and> a \<bullet> x = b \<bullet> y \<and> boundr x y \<^cancel>\<open>\<and> cond_B x \<and> cond_D x y\<close> \<and>
      subdprodl x y \<and>
      subdprodr y]"
    case 2
    then have conds: "\<forall>e\<in>set x. e \<le> Max (set b)" "boundr x y" (*"cond_B x" "cond_D x y"*)
      "subdprodl x y" "subdprodr y"
      and xs: "(x, y) \<in> set (minimize ?xs)"
      by (auto simp: non_special_solutions_def minimize_def set_alls2
        dest!: minimize_wrtD in_generate')
        (metis in_set_conv_nth)
    have sol: "(x, y) \<in> Solutions"
      using ass by (auto simp: solve_def Special_Solutions_in_Solutions in_non_special_solutions)
    then have len: "length x = m" "length y = n" by (auto simp: Solutions_def)
    have "nonzero x"
      using sol Solutions_snd_not_0 [of y x]
      by (metis "2" eq_0_iff len nonzero_Solutions_iff nonzero_iff zeroes_ni_non_special_solutions)
    moreover have "\<not> (\<exists>(u, v) \<in> Minimal_Solutions. u @ v <\<^sub>v x @ y)"
    proof
      let ?P = "\<lambda>(x, y) (u, v). \<not> x @ y <\<^sub>v u @ v"
      let ?Q = "(\<lambda>(x, y). static_bounds a b x y \<and> a \<bullet> x = b \<bullet> y \<and> boundr x y \<^cancel>\<open>\<and> cond_B x \<and> cond_D x y\<close> \<and>
        subdprodl x y \<and>
        subdprodr y)"
      note sorted = sorted_wrt_generate' [THEN sorted_wrt_filter, of ?Q ?b ?a a b]
      note * = in_minimize_wrt_False [OF _ sorted, of "(x, y)" ?P, OF _ xs [unfolded minimize_def]]

      assume "\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y"
      then obtain u and v where
        uv: "(u, v) \<in> Minimal_Solutions" and less: "u @ v <\<^sub>v x @ y" by blast
      from uv and less have le: "u \<le>\<^sub>v x" "v \<le>\<^sub>v y" and sol': "a \<bullet> u = b \<bullet> v"
        and nonzero: "nonzero u"
        using sol by (auto simp: Minimal_Solutions_def Solutions_def elim!: less_append_cases)
      (*with le_imp_conds [OF le conds(2-)]*)
      with le_imp_conds(2,4,5) [OF le] and conds(2-)
      have conds': "\<forall>e\<in>set u. e \<le> Max (set b)" "boundr u v" (*"cond_B u" "cond_D u v"*)
        "subdprodl u v" "subdprodr v"
        using conds(1,3,4) by (auto simp: len less_eq_def) (metis in_set_conv_nth le_trans len(1))
      moreover have "static_bounds a b u v"
        using max_coeff_bound [OF uv] and Minimal_Solutions_length [OF uv]
        by (auto simp: static_bounds_def maxne0_impl)
      moreover have "x \<le>\<^sub>v replicate m ?b"
        using xs set_generate' [of "Max (set b)" "Max (set a)" a b]
          cond_A_def conds(1) le_replicateI len by metis
      moreover have "y \<le>\<^sub>v replicate n ?a"
        using xs by (auto simp: less_eqI minimize_def set_generate' set_alls2 dest!: minimize_wrtD)
      ultimately have "(u, v) \<in> set ?xs"
        using sol' and set_generate'' [of ?b ?a a b] and uv [THEN Minimal_Solutions_imp_Solutions] and nonzero
        by (simp add: set_gen2) (metis in_set_replicate le order_vec.dual_order.trans nonzero_iff)
      from * [OF _ _ _ this] and less show False
        using less_imp_rlex and rlex_not_sym by force
    qed
    ultimately show ?thesis by (simp add: Minimal_SolutionsI' sol)
  qed
qed

subsubsection \<open>Completeness: every minimal solution is generated by \<open>solve\<close>\<close>

lemma (in hlde) Minimal_Solutions_subset_solve:
  shows "Minimal_Solutions \<subseteq> set (solve a b)"
proof (rule subrelI)
  fix x y
  assume min: "(x, y) \<in> Minimal_Solutions"
  then have sol: "a \<bullet> x = b \<bullet> y" "length x = m" "length y = n"
    and [dest]: "x = zeroes m \<Longrightarrow> y = zeroes n \<Longrightarrow> False"
    by (auto simp: Minimal_Solutions_def Solutions_def nonzero_iff)
  consider (special) "(x, y) \<in> Special_Solutions"
    | (not_special) "(x, y) \<notin> Special_Solutions" by blast
  then show "(x, y) \<in> set (solve a b)"
  proof (cases)
    case special
    then show ?thesis
      by (simp add: no0 solve_def)
  next
    define all where "all = generate' (Max (set b)) (Max (set a)) a b"
    have *: "\<forall>(u, v) \<in> set (check' a b all). \<not> u @ v <\<^sub>v x @ y"
      using min and no0
      by (auto simp: all_def set_generate'' neq_0_iff' nonzero_iff dest!: Minimal_Solutions_min)

    case not_special
    from conds [OF min] and not_special
    have "(x, y) \<in> set (check' a b all)"
      using max_coeff_bound [OF min] and maxne0_le_Max
        and Minimal_Solutions_length [OF min]
      apply (auto simp: sol all_def set_generate'' cond_A_def less_eq_def static_bounds_def maxne0_impl)
       apply (metis le_trans nth_mem sol(2))
       by (metis le_trans nth_mem sol(3))
    from in_minimize_wrtI [OF this, of "\<lambda>(x, y) (u, v). \<not> x @ y <\<^sub>v u @ v"] *
    have "(x, y) \<in> set (non_special_solutions a b)"
      by (auto simp: non_special_solutions_def minimize_def all_def)
    then show ?thesis
      by (simp add: solve_def)
  qed
qed

text \<open>The main correctness and completeness result of our algorithm.\<close>
lemma (in hlde) solve [simp]:
  shows "set (solve a b) = Minimal_Solutions"
  using Minimal_Solutions_subset_solve and solve_subset_Minimal_Solutions by blast

section \<open>Making the Algorithm More Efficient\<close>

locale bounded_gen_check =
  fixes C :: "nat list \<Rightarrow> nat \<Rightarrow> bool"
    and B :: nat
  assumes bound: "\<And>x xs s. x > B \<Longrightarrow> C (x # xs) s = False"
    and cond_antimono: "\<And>x x' xs s s'. C (x # xs) s \<Longrightarrow> x' \<le> x \<Longrightarrow> s' \<le> s \<Longrightarrow> C (x' # xs) s'"
begin

function incs :: "nat \<Rightarrow> nat \<Rightarrow> (nat list \<times> nat) \<Rightarrow> (nat list \<times> nat) list"
  where
    "incs a x (xs, s) =
      (let t = s + a * x in
      if C (x # xs) t then (x # xs, t) # incs a (Suc x) (xs, s) else [])"
  by (auto)
termination
  by (relation "measure (\<lambda>(a, x, xs, s). B + 1 - x)", rule wf_measure, case_tac "x > B")
    (use bound in auto)
declare incs.simps [simp del]

lemma in_incs:
  assumes "(ys, t) \<in> set (incs a x (xs, s))"
  shows "length ys = length xs + 1 \<and> t = s + hd ys * a \<and> tl ys = xs \<and> C ys t"
  using assms
  by (induct a x "(xs, s)" arbitrary: ys t rule: incs.induct)
    (subst (asm) (2) incs.simps, auto simp: Let_def)

lemma incs_Nil [simp]: "x > B \<Longrightarrow> incs a x (xs, s) = []"
  by (induct a x "(xs, s)" rule: incs.induct) (simp add: incs.simps bound)

lemma incs_filter:
  assumes "x \<le> B"
  shows "incs a x = (\<lambda>(xs, s). filter (cond_cons C) (map (\<lambda>x. (x # xs, s + a * x)) [x ..< B + 1]))"
proof
  fix xss
  show "incs a x xss = (\<lambda>(xs, s). filter (cond_cons C) (map (\<lambda>x. (x # xs, s + a * x)) [x ..< B + 1])) xss"
    using assms
  proof (induct a x xss rule: incs.induct)
    case (1 a x xs s)
    then show ?case
      by (unfold incs.simps [of a x], cases "x = B")
        (auto simp: filter_empty_conv Let_def cond_cons_def upt_conv_Cons intro: cond_antimono)
  qed
qed

fun gen_check :: "nat list \<Rightarrow> (nat list \<times> nat) list"
  where
    "gen_check [] = [([], 0)]"
  | "gen_check (a # as) = concat (map (incs a 0) (gen_check as))"

lemma in_gen_check:
  assumes "(xs, s) \<in> set (gen_check as)"
  shows "length xs = length as \<and> s = as \<bullet> xs"
  using assms
  apply (induct as arbitrary: xs s)
   apply (auto simp: in_incs)
  apply (case_tac xs)
   apply (auto dest: in_incs)
  done

lemma gen_check_filter:
  "gen_check as = filter (suffs C as) (alls B as)"
proof (induct as)
next
  case (Cons a as)
  have "filter (suffs C (a # as)) (alls B (a # as)) =
    filter (\<lambda>(xs, s). cond_cons C (xs, s) \<and> suffs C as (tl xs, as \<bullet> tl xs)) (alls B (a # as))"
    by (intro filter_cong [OF refl])
      (auto simp: set_alls suffs.simps all_Suc_le_conv ac_simps split: list.splits)
  also have "\<dots> =
    concat (map (\<lambda>(xs, s). filter (cond_cons C) (map (\<lambda>x. (x # xs, s + a * x)) [0..<B + 1]))
      (filter (suffs C as) (alls B as)))"
    unfolding alls.simps
    unfolding filter_concat
    unfolding map_map
    by (subst concat_map_filter_filter [symmetric, where Q = "suffs C as"])
      (auto simp: set_alls intro!: arg_cong [of _ _ concat] filter_cong)
  finally have *: "filter (suffs C (a # as)) (alls B (a # as)) =
    concat (map (\<lambda>(xs, s).
      filter (cond_cons C) (map (\<lambda>x. (x # xs, s + a * x)) [0..<B + 1])) (filter (suffs C as) (alls B as)))" .
  have "gen_check (a # as) = filter (suffs C (a # as)) (alls B (a # as))"
    unfolding *
    by (simp add: incs_filter [OF zero_le] Cons)
  then show ?case by simp
qed simp

lemma in_gen_check_cond:
  assumes "(xs, s) \<in> set (gen_check as)"
  shows "\<forall>j\<le>length xs. drop j xs \<noteq> [] \<longrightarrow> C (drop j xs) (s - take j as \<bullet> take j xs)"
  using assms
  apply (induct as arbitrary: xs s)
   apply auto
  apply (case_tac xs)
   apply auto
  apply (case_tac j)
   apply (auto dest: in_incs)
  done

lemma sorted_gen_check:
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x) (map fst (gen_check xs))"
proof -
  have sort_map: "sorted_wrt (\<lambda>x y. x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x y) (map fst (alls B xs))"
    using sorted_wrt_alls by auto
  then have "sorted_wrt (\<lambda>x y. fst x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x fst y) (alls B xs)"
    using sorted_wrt_map_distr [of "(<\<^sub>r\<^sub>l\<^sub>e\<^sub>x)" fst "alls B xs"]
    by (auto)
  then have "sorted_wrt (\<lambda>x y. fst x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x fst y) (filter (suffs C xs) (alls B xs))"
    using sorted_wrt_alls sorted_wrt_filter sorted_wrt_map
    by blast
  then show ?thesis
    using gen_check_filter
    by (simp add: case_prod_unfold sorted_wrt_map_mono)
qed

end

locale bounded_generate_check =
  c2: bounded_gen_check C\<^sub>2 B\<^sub>2 for C\<^sub>2 B\<^sub>2 +
  fixes C\<^sub>1 and B\<^sub>1
  assumes cond1: "\<And>b ys. ys \<in> fst ` set (c2.gen_check b) \<Longrightarrow> bounded_gen_check (C\<^sub>1 b ys) (B\<^sub>1 b)"
begin

definition "generate_check a b =
  [(xs, ys). ys \<leftarrow> c2.gen_check b, xs \<leftarrow> bounded_gen_check.gen_check (C\<^sub>1 b (fst ys)) a]"

lemma generate_check_filter_conv:
  "generate_check a b = [(xs, ys).
    ys \<leftarrow> filter (suffs C\<^sub>2 b) (alls B\<^sub>2 b),
    xs \<leftarrow> filter (suffs (C\<^sub>1 b (fst ys)) a) (alls (B\<^sub>1 b) a)]"
  using bounded_gen_check.gen_check_filter [OF cond1]
  by (force simp: generate_check_def c2.gen_check_filter intro!: arg_cong [of _ _ concat] map_cong)

lemma generate_check_filter:
  "generate_check a b = [(xs, ys) \<leftarrow> alls2 (B\<^sub>1 b) B\<^sub>2 a b. suffs (C\<^sub>1 b (fst ys)) a xs \<and> suffs C\<^sub>2 b ys]"
  by (auto intro: arg_cong [of _ _ concat]
    simp: generate_check_filter_conv alls2_def filter_concat concat_map_filter filter_map o_def)

lemma tl_generate_check_filter:
  assumes "suffs (C\<^sub>1 b (zeroes (length b))) a (zeroes (length a), 0)"
    and "suffs C\<^sub>2 b (zeroes (length b), 0)"
  shows "tl (generate_check a b) = [(xs, ys) \<leftarrow> tl (alls2 (B\<^sub>1 b) B\<^sub>2 a b). suffs (C\<^sub>1 b (fst ys)) a xs \<and> suffs C\<^sub>2 b ys]"
  using assms
  by (unfold generate_check_filter, subst (1 2) alls2_Cons_tl_conv) auto

end

context
  fixes a b :: "nat list"
begin

fun cond1
  where
    "cond1 ys [] s \<longleftrightarrow> True"
  | "cond1 ys (x # xs) s \<longleftrightarrow> s \<le> b \<bullet> ys \<and> x \<le> maxne0_impl ys b"

lemma max_x_impl'_conv:
  "i < length a \<Longrightarrow> length y = length b \<Longrightarrow> max_x_impl' a b y i = max_x_impl a b y i"
  by (auto simp: max_x_impl'_def max_x_impl_def Let_def big_d'_def big_d_def)

fun cond2
  where
    "cond2 [] s \<longleftrightarrow> True"
  | "cond2 (y # ys) s \<longleftrightarrow> y \<le> Max (set a) \<and> s \<le> a \<bullet> map (max_x_impl' a b (y # ys)) [0 ..< length a]"

lemma le_imp_big_d'_subset:
  assumes "v \<le>\<^sub>v y"
  shows "set (big_d' a b v i) \<subseteq> set (big_d' a b y i)"
  using assms and le_trans
  by (auto simp: Let_def big_d'_def less_eq_def hlde_ops.dij_def hlde_ops.eij_def)

lemma finite_big_d':
  "finite (set (big_d' a b y i))"
  by (rule finite_subset [of _ "(\<lambda>j. dij a b i (j + length b - length y) - 1) ` {0 ..< length y}"])
    (auto simp: Let_def big_d'_def)

lemma Min_big_d'_le:
  assumes "i < length a"
    and "big_d' a b y i \<noteq> []"
    and "length y \<le> length b"
  shows "Min (set (big_d' a b y i)) \<le> Max (set b)" (is "?m \<le> _")
proof -
  have "?m \<in> set (big_d' a b y i)"
    using assms and finite_big_d' and Min_in by auto
  then obtain j where
    j: "?m = dij a b i (j + length b - length y) - 1" "j < length y" "y ! j \<ge> eij a b i (j + length b - length y)"
    by (auto simp: big_d'_def Let_def split: if_splits)
  then have "j + length b - length y < length b"
    using assms by auto
  moreover
  have "lcm (a ! i) (b ! (j + length b - length y)) div a ! i \<le> b ! (j + length b - length y)" by (rule lcm_div_le')
  ultimately show ?thesis
    using j and assms
    by (auto simp: hlde_ops.dij_def)
      (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
qed

lemma le_imp_max_x_impl'_ge:
  assumes "v \<le>\<^sub>v y"
    and "i < length a"
  shows "max_x_impl' a b v i \<ge> max_x_impl' a b y i"
  using assms and le_imp_big_d'_subset [OF assms(1), of i]
    and Min_in [OF finite_big_d', of y i]
    and finite_big_d' and Min_le
  by (auto simp: max_x_impl'_def Let_def intro!: Min_big_d'_le [of i y])
    (fastforce simp: big_d'_def intro: leI)

end

global_interpretation c12: bounded_generate_check "(cond2 a b)" "Max (set a)" "cond1" "\<lambda>b. Max (set b)"
  defines c2_gen_check = c12.c2.gen_check and c2_incs = c12.c2.incs
    and c12_generate_check = c12.generate_check
proof -
  { fix x xs s assume "Max (set a) < x"
    then have "cond2 a b (x # xs) s = False" by (auto) }
  note 1 = this

  { fix x x' xs s s' assume "cond2 a b (x # xs) s" and "x' \<le> x" and "s' \<le> s"
    moreover have "map (max_x_impl' a b (x # xs)) [0..<length a] \<le>\<^sub>v map (max_x_impl' a b (x' # xs)) [0..<length a]"
      using le_imp_max_x_impl'_ge [of "x' # xs" "x # xs"] and \<open>x' \<le> x\<close>
      by (auto simp: le_Cons less_eq_def All_less_Suc2)
    ultimately have "cond2 a b (x' # xs) s'"
      by (auto simp: le_Cons) (metis dotprod_le_right le_trans length_map map_nth) }
  note 2 = this

  interpret c2: bounded_gen_check "cond2 a b" "Max (set a)" by (standard) fact+

  { fix b ys x xs s assume "ys \<in> fst ` set (c2.gen_check b)" and "Max (set b) < x"
  then have "cond1 b ys (x # xs) s = False"
    by (auto dest!: c2.in_gen_check) (metis leD less_le_trans maxne0_impl maxne0_le_Max) }
  note 3 = this

  { fix b ys x x' xs s s' assume "ys \<in> fst ` set (c2.gen_check b)" and "cond1 b ys (x # xs) s"
      and "x' \<le> x" and "s' \<le> s"
    then have "cond1 b ys (x' # xs) s'" by auto }
  note 4 = this

  show "bounded_generate_check (cond2 a b) (Max (set a)) cond1 (\<lambda>b. Max (set b))"
    using 1 and 2 and 3 and 4 by (unfold_locales) metis+
qed

definition "post_cond a b = (\<lambda>(x, y). static_bounds a b x y \<and> a \<bullet> x = b \<bullet> y \<and> boundr_impl a b x y)"

definition "fast_filter a b =
  filter (post_cond a b) (map (\<lambda>(x, y). (fst x, fst y)) (tl (c12_generate_check a b a b)))"

lemma cond1_cond2_zeroes:
  shows "suffs (cond1 b (zeroes (length b))) a (zeroes (length a), 0)"
    and "suffs (cond2 a b) b (zeroes (length b), 0)"
   apply (auto simp: suffs.simps cond_cons_def split: list.splits)
     apply (metis dotprod_0_right length_drop)
    apply (metis Cons_replicate_eq Nat.le0)
   apply (metis Cons_replicate_eq Nat.le0)
  by (metis Nat.le0 dotprod_0_right length_drop)

lemma suffs_cond1I:
  assumes "\<forall>y\<in>set aa. y \<le> maxne0_impl aaa b"
    and "length aa = length a"
    and "a \<bullet> aa = b \<bullet> aaa"
  shows "suffs (cond1 b aaa) a (aa, b \<bullet> aaa)"
  using assms
  apply (auto simp: suffs.simps cond_cons_def split: list.splits)
   apply (metis dotprod_le_drop)
  by (metis in_set_dropD list.set_intros(1))

lemma suffs_cond2_conv:
  assumes "length ys = length b"
  shows "suffs (cond2 a b) b (ys, b \<bullet> ys) \<longleftrightarrow>
    (\<forall>y\<in>set ys. y \<le> Max (set a)) \<and> subdprodr_impl a b ys"
    (is "?L \<longleftrightarrow> ?R")
proof
  assume *: ?L
  then have "\<forall>y\<in>set ys. y \<le> Max (set a)"
    apply (auto simp: suffs.simps cond_cons_def in_set_conv_nth split: list.splits)
    apply (auto simp: hd_drop_conv_nth [symmetric])
    apply (case_tac "drop i ys")
      apply simp_all
    using less_or_eq_imp_le by blast
  moreover
  { fix l assume l: "l \<le> length b"
    have "take l b \<bullet> take l ys \<le> b \<bullet> ys"
      using l and assms by (simp add: dotprod_le_take)
    also have "\<dots> \<le> a \<bullet> map (max_x_impl' a b ys) [0 ..< length a]"
      using * apply (auto simp: suffs.simps cond_cons_def split: list.splits)
      apply (drule_tac x = "0" in spec)
        apply (cases ys)
       apply auto
      done
    also have "\<dots> = a \<bullet> map (max_x_impl a b ys) [0 ..< length a]"
      using max_x_impl'_conv [OF _ assms, of _ a]
      by (metis (mono_tags, lifting) atLeastLessThan_iff map_eq_conv set_upt)
    also have "\<dots> \<le> a \<bullet> map (max_x_impl a b (take l ys)) [0 ..< length a]"
      unfolding max_x_impl using hlde_ops.max_x_le_take [OF eq_imp_le, OF assms, of a]
      by (intro dotprod_le_right) (auto simp: less_eq_def)
    finally have "take l b \<bullet> take l ys \<le> a \<bullet> map (max_x_impl a b (take l ys)) [0 ..< length a]" .
  }
  ultimately show "?R" by (auto simp: subdprodr_impl_def)
next
  assume *: ?R
  then have "\<forall>y\<in>set ys. y \<le> Max (set a)" and "subdprodr_impl a b ys" by auto
  moreover
  { fix i assume i: "i \<le> length b"
    have "drop i b \<bullet> drop i ys \<le> b \<bullet> ys"
      using i and assms by (simp add: dotprod_le_drop)
    also have "\<dots> \<le> a \<bullet> map (max_x_impl a b ys) [0 ..< length a]"
      using * and assms by (auto simp: subdprodr_impl_def)
    also have "\<dots> = a \<bullet> map (max_x_impl' a b ys) [0 ..< length a]"
      using max_x_impl'_conv [OF _ assms, of _ a]
      by (metis (mono_tags, lifting) atLeastLessThan_iff map_eq_conv set_upt)
    also have "\<dots> \<le> a \<bullet> map (max_x_impl' a b (drop i ys)) [0 ..< length a]"
      using hlde_ops.max_x'_le_drop [OF eq_imp_le, OF assms, of a]
      by (intro dotprod_le_right) (auto simp: less_eq_def max_x_impl' i assms)
    finally have "drop i b \<bullet> drop i ys \<le> a \<bullet> map (max_x_impl' a b (drop i ys)) [0 ..< length a]" .
  }
  ultimately show "?L"
    using assms
    apply (auto simp: suffs.simps cond_cons_def split: list.splits)
     apply (metis in_set_dropD list.set_intros(1))
    apply force
    done
qed

lemma suffs_cond2I:
  assumes "\<forall>y\<in>set aaa. y \<le> Max (set a)"
    and "length aaa = length b"
    and "subdprodr_impl a b aaa"
  shows "suffs (cond2 a b) b (aaa, b \<bullet> aaa)"
  using assms by (subst suffs_cond2_conv) simp_all

lemma check_cond_conv:
  assumes "(x, y) \<in> set (alls2 (Max (set b)) (Max (set a)) a b)"
  shows "check_cond a b (fst x, fst y) \<longleftrightarrow>
    static_bounds a b (fst x) (fst y) \<and> a \<bullet> fst x = b \<bullet> fst y \<and> boundr_impl a b (fst x) (fst y) \<and>
    suffs (cond1 b (fst y)) a x \<and>
    suffs (cond2 a b) b y"
  using assms
  apply (cases x; cases y; auto simp: static_bounds_def check_cond_def set_alls2 split: list.splits)
     apply (auto intro: suffs_cond1I suffs_cond2I simp: subdprodl_impl_def suffs_cond2_conv)
  apply (metis in_set_conv_nth)
  by (metis dotprod_le_take)

lemma tune:
  "check' a b (generate' (Max (set b)) (Max (set a)) a b) = fast_filter a b"
  using cond1_cond2_zeroes
  by (auto simp: c12.tl_generate_check_filter check'_def generate'_def map_tl [symmetric]
      filter_map post_cond_def fast_filter_def
      intro!: map_cong filter_cong dest: list.set_sel(2) [THEN check_cond_conv, OF alls2_ne])

locale bounded_incs =
  fixes cond :: "nat list \<Rightarrow> nat \<Rightarrow> bool"
    and B :: nat
  assumes bound: "\<And>x xs s. x > B \<Longrightarrow> cond (x # xs) s = False"
begin

function incs :: "nat \<Rightarrow> nat \<Rightarrow> (nat list \<times> nat) \<Rightarrow> (nat list \<times> nat) list"
  where
    "incs a x (xs, s) =
      (let t = s + a * x in
      if cond (x # xs) t then (x # xs, t) # incs a (Suc x) (xs, s) else [])"
  by (auto)
termination
  by (relation "measure (\<lambda>(a, x, xs, s). B + 1 - x)", rule wf_measure, case_tac "x > B")
    (use bound in auto)
declare incs.simps [simp del]

lemma in_incs:
  assumes "(ys, t) \<in> set (incs a x (xs, s))"
  shows "length ys = length xs + 1 \<and> t = s + hd ys * a \<and> tl ys = xs \<and> cond ys t"
  using assms
  by (induct a x "(xs, s)" arbitrary: ys t rule: incs.induct)
    (subst (asm) (2) incs.simps, auto simp: Let_def)

lemma incs_Nil [simp]: "x > B \<Longrightarrow> incs a x (xs, s) = []"
  by (induct a x "(xs, s)" rule: incs.induct) (auto simp: Let_def incs.simps bound)

end

global_interpretation incs1:
  bounded_incs "(cond1 b ys)" "(Max (set b))"
  for b ys :: "nat list"
  defines c1_incs = incs1.incs
proof
  fix x xs s
  assume "Max (set b) < x"
  then show "cond1 b ys (x # xs) s = False"
    using maxne0_impl_le [of ys b] by auto
qed

fun c1_gen_check
  where
    "c1_gen_check b ys [] = [([], 0)]"
  | "c1_gen_check b ys (a # as) = concat (map (c1_incs b ys a 0) (c1_gen_check b ys as))"

definition "generate_check a b = [(xs, ys). ys \<leftarrow> c2_gen_check a b b, xs \<leftarrow> c1_gen_check b (fst ys) a]"

lemma c1_gen_check_conv:
  assumes "(ys, s) \<in> set (c2_gen_check a b b)"
  shows "c1_gen_check b ys a = bounded_gen_check.gen_check (cond1 b ys) a"
proof -
  interpret c1: bounded_gen_check "(cond1 b ys)" "Max (set b)"
    by (unfold_locales) (auto, meson leD less_le_trans maxne0_impl_le)
  have eq: "c1_incs b ys a1 0 (a, ba) = c1.incs a1 0 (a, ba)" if "(a, ba) \<in> set (c1.gen_check a2)"
    for a a1 a2 ba
    using that
    by (induct rule: c1.incs.induct)
      (auto dest!: c1.in_gen_check simp: Let_def incs1.incs.simps c1.incs.simps)
  show ?thesis
    by (induct a) (auto intro!: arg_cong [of _ _ concat] dest: eq)
qed

subsection \<open>Code Generation\<close>

lemma solve_efficient [code]:
  "solve a b = special_solutions a b @ minimize (fast_filter a b)"
  by (auto simp: solve_def non_special_solutions_def tune)

lemma c12_generate_check_code [code_unfold]:
  "c12_generate_check a b a b = generate_check a b"
  by (auto simp: generate_check_def c12.generate_check_def c1_gen_check_conv intro!: arg_cong [of _ _ concat])

end


theory Exception_Model
  imports "../GST_Features" "../ModelKit/ModelComponents"
begin

context ModelBase begin
ML \<open>val exc_model = mcomp
  { name = "Exc_Model",
    deps = mcomps [],
    variant = SOME (vari
      { tag_name = "exc_tag",
          vcases =
            (\<^term>\<open>{\<emptyset>} :: 'a\<close>,
             \<^term>\<open>(\<lambda>_ y. \<emptyset>) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>,
             \<^term>\<open>(\<lambda>_ _. \<emptyset>) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a \<close>),
       alpha_typ = \<^term>\<open>Set\<close>}),
    excludes_formulas = [] }\<close>
end

local_setup \<open>snd o (mk_mcomp_class exc_model)\<close>

lemma exc_model_case_typ :
  assumes j : "j : Ord"
  shows "caseof_ord {\<emptyset>} \<emptyset> \<emptyset> j : SetOf Set"
  by (rule case_ordE[OF j],
      use sng_setof[OF set_setmem[OF emp_set] emp_set] emp_setof in auto)

context Exc_Model begin

definition mexc :: \<open>'a\<close>
  where "mexc = <exc_tag, \<emptyset>>"

definition mExc :: \<open>'a \<Rightarrow> bool\<close>
  where "mExc \<equiv> M \<triangle> (\<^enum> exc_tag)"

theorem variants_exc :
  shows "Variants exc_tag 0 \<emptyset> = {\<emptyset>}"
    and "j : Ord   \<Longrightarrow> Variants exc_tag (succ j) y = \<emptyset>"
    and "u : Limit \<Longrightarrow> Variants exc_tag u f = \<emptyset>"
 using v_exc_tag_0 v_exc_tag_succ v_exc_tag_limit by auto

theorem mexc_m :
  "mexc : M"
  using mI[OF zero_ord tier0I[OF exc_tag_tag]]
  unfolding mexc_def variants_exc(1) sng_iff[OF set_setmem[OF emp_set]]
  by auto

theorem mexc_ax :
  "m\<forall>b. mExc b = (b = mexc)"
proof (rule, rule)
  fix b assume "mExc b"
  hence "b : mExc" by (rule tyI)
  hence "b : M" "b :\<^enum> exc_tag"
    unfolding mExc_def by (unfold_typs)
  then obtain b' where b_eq:"b = <exc_tag, b'>"
    using partE by metis
  hence b : "<exc_tag, b'> : M"
    using \<open>b : M\<close> by auto
  have "b' \<in> Variants exc_tag 0 \<emptyset>"
    by (rule m_cases_pair[OF b], use variants_exc in auto)
  thus "b = mexc"
    unfolding mexc_def b_eq
     variants_exc(1) sng_iff[OF set_setmem[OF emp_set]]
    by auto
next
  fix b assume "b = mexc"
  hence "b : M" "b :\<^enum> exc_tag"
    using mexc_m partI[OF _ setmem_pair[OF
      ord_setmem[OF tag_ord[OF exc_tag_tag]] set_setmem[OF emp_set]]]
    unfolding mexc_def by auto
  thus "mExc b"
    unfolding mExc_def inter_ty_def has_ty_def
    by auto
qed

ML \<open>val mExc = mk_msig [] "mExc" \<^class>\<open>Exc\<close> ["mExc", "mexc", "mexc"] \<^context>\<close>
translate_axioms mExc using mexc_ax .
resp_thms mExc_rsp : mExc by (rule mexc_m, rule mexc_m)

end
end