theory ListDemoLemmaExpl
imports "$HIPSTER_HOME/IsaHipster"
begin
ML\<open>
Goal.prove; Variable.auto_fixes

\<close>

ML Thm.assume

ML\<open>

val t = Thm.assume @{cprop "x = x"};

(* Handle binding stuff in context for just proof *)
fun f ctxt = Goal.prove ctxt ["x"] [@{prop True}] @{prop "x = x"}
  (fn args => no_tac) handle ERROR _ => TrueI

val r = f @{context}

\<close>

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun app :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "app Emp xs = xs"
| "app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a Lst \<Rightarrow> 'a Lst"
where
  "rev Emp = Emp"
| "rev (Cons x xs) = app (rev xs) (Cons x Emp)"

fun qrev :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "qrev Emp a = a"
| "qrev (Cons x xs) a = qrev xs (Cons x a)"

 hipster app
lemma lemma_a [thy_expl]: "app a Emp = a"
  apply lemma_explore
  apply (induct a)
  apply simp
  apply simp
  done

lemma lemma_aa [thy_expl]: "app (app y z) x2 = app y (app z x2)"
  apply (induct y arbitrary: x2 z)
  apply simp
  apply simp
  done

 hipster rev app
lemma lemma_ab [thy_expl]: "app (ListDemoLemmaExpl.rev z) (ListDemoLemmaExpl.rev y) = ListDemoLemmaExpl.rev (app y z)"
  apply (induct y arbitrary: z)
  apply simp
  apply (simp add: lemma_a)
  apply simp
apply (metis lemma_aa)
  done

lemma lemma_ac [thy_expl]: "ListDemoLemmaExpl.rev (Lst.Cons z (ListDemoLemmaExpl.rev y)) = app y (Lst.Cons z Emp)"
  apply (induct y)
  apply simp
apply simp
  apply (metis ListDemoLemmaExpl.rev.simps(1) ListDemoLemmaExpl.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
  done

lemma lemma_ad [thy_expl]: "ListDemoLemmaExpl.rev (app z (ListDemoLemmaExpl.rev y)) = app y (ListDemoLemmaExpl.rev z)"
  apply (induct y arbitrary: z)
  apply simp
apply (simp add: lemma_a)
apply simp
apply (metis ListDemoLemmaExpl.rev.simps(1) ListDemoLemmaExpl.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
done

(*lemma lemma_ab [thy_expl]: "app (ListDemo.rev x5) (ListDemo.rev y5) = ListDemo.rev (app y5 x5)"
apply (induct y5)
sledgehammer
apply (metis ListDemo.rev.simps(1) app.simps(1) lemma_a)
sledgehammer
by (metis ListDemo.rev.simps(2) app.simps(2) lemma_aa)
*)

theorem rev_rev : "rev(rev xs) = xs "
  apply (induct xs)
  apply simp
  apply simp
  apply (metis ListDemoLemmaExpl.rev.simps(1) ListDemoLemmaExpl.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
  done

 (* sledgehammer
  by (metis ListDemo.rev.simps(1) lemma_a lemma_ad)*)
(*apply (induct xs)
sledgehammer
(* apply (tactic {* Hipster_Explore.explore_goal @{context} ["ListDemo.rev", "ListDemo.app"] *}) *)
apply (metis ListDemo.rev.simps(1))
apply simp
sledgehammer
by (metis ListDemo.rev.simps(1) ListDemo.rev.simps(2) app.simps(1) app.simps(2) lemma_ab)
*)
(*
Try first proving lemmas:

lemma lemma_a [thy_expl]: "app x2 Emp = x2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

lemma lemma_aa [thy_expl]: "app (app x2 y2) z2 = app x2 (app y2 z2)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

lemma lemma_ab [thy_expl]: "app (ListDemo.rev x5) (ListDemo.rev y5) = ListDemo.rev (app y5 x5)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.rev.simps ListDemo.app.simps thy_expl} *})

then prove the open goal ListDemo.rev (ListDemo.rev xs) = xs by (tactic {*Simp_Metis_Tacs.routine_tac @{context}*})
*)

ML\<open>Hipster_Explore.explore @{context} ["ListDemo.app", "ListDemo.rev", "ListDemo.qrev"];
\<close>
lemma lemma_a' [thy_expl]: "app x2 Emp = x2"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

lemma lemma_aa' [thy_expl]: "qrev (qrev x2 y2) z2 = qrev y2 (app x2 z2)"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

lemma lemma_ab' [thy_expl]: "qrev (ListDemo.rev x5) y5 = app x5 y5"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)
thm thy_expl

setup \<open>Hipster_Explore.setup_exploration ["ListDemo.app", "ListDemo.rev", "ListDemo.qrev"];
\<close>

thm thy_expl

theorem rev_qrev : "rev xs = qrev xs Emp"
apply (induct xs)
apply simp
apply simp
by (metis thy_expl qrev.simps(1))
(*
apply (tactic {* Hipster_Explore.explore_goal @{context} ["ListDemo.rev", "ListDemo.app", "ListDemo.qrev"] *})
*)
ML \<open>\<close>

(*

lemma lemma_a [thy_expl]: "app x2 Emp = x2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma lemma_aa [thy_expl]: "qrev (qrev x2 y2) z2 = qrev y2 (app x2 z2)"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma lemma_ab [thy_expl]: "qrev (ListDemo.rev x5) y5 = app x5 y5"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl} *})

lemma rev_qrev: "rev xs = qrev xs Emp"
sledgehammer
by (metis lemma_a lemma_aa lemma_ab)

lemma rev_rev : "rev(rev xs) = xs"
sledgehammer
by (metis lemma_a lemma_ab rev_qrev)

ML{* Hipster_Explore.explore @{context} ["ListDemo.qrev", "ListDemo.rev"]; *}

lemma f
 explore
proof -
  have lemma1: f
    proof
  have lemma2: g
    proof
  from lemma1 lemma2 show ?thesis
    proof
qed

*)
lemma lemma_ab'' [thy_expl]: "qrev x5 Emp = ListDemo.rev x5"
by (tactic \<open>Hipster_Tacs.induct_simp_metis @{context} @{thms ListDemo.app.simps ListDemo.rev.simps ListDemo.qrev.simps thy_expl}\<close>)

end


(* Title:     HOL/MiniML/Type.thy

   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "MiniML-types and type substitutions"

theory Type
imports Maybe
begin

\<comment> \<open>type expressions\<close>
datatype "typ" = TVar nat | Fun "typ" "typ" (infixr "->" 70)

\<comment> \<open>type schemata\<close>
datatype type_scheme = FVar nat | BVar nat | SFun type_scheme type_scheme (infixr "=->" 70)

\<comment> \<open>embedding types into type schemata\<close>
primrec mk_scheme :: "typ => type_scheme" where
  "mk_scheme (TVar n) = (FVar n)"
| "mk_scheme (t1 -> t2) = ((mk_scheme t1) =-> (mk_scheme t2))"

\<comment> \<open>type variable substitution\<close>
type_synonym subst = "nat => typ"

class type_struct =
  fixes free_tv :: "'a => nat set"
    \<comment> \<open>@{text "free_tv s"}: the type variables occurring freely in the type structure s\<close>
  fixes free_tv_ML :: "'a => nat list"
    \<comment> \<open>executable version of @{text free_tv}: Implementation with lists\<close>
  fixes bound_tv :: "'a => nat set"
    \<comment> \<open>@{text "bound_tv s"}: the type variables occurring bound in the type structure s\<close>
  fixes min_new_bound_tv :: "'a => nat"
    \<comment> \<open>minimal new free / bound variable\<close>
  fixes app_subst :: "subst => 'a => 'a" ("$")
    \<comment> \<open>extension of substitution to type structures\<close>

instantiation "typ" :: type_struct
begin

primrec free_tv_typ where
  free_tv_TVar:    "free_tv (TVar m) = {m}"
| free_tv_Fun:     "free_tv (t1 -> t2) = (free_tv t1) Un (free_tv t2)"

primrec app_subst_typ where
  app_subst_TVar: "$ S (TVar n) = S n"
| app_subst_Fun:  "$ S (t1 -> t2) = ($ S t1) -> ($ S t2)"

instance ..

end

instantiation type_scheme :: type_struct
begin

primrec free_tv_type_scheme where
  "free_tv (FVar m) = {m}"
| "free_tv (BVar m) = {}"
| "free_tv (S1 =-> S2) = (free_tv S1) Un (free_tv S2)"

primrec free_tv_ML_type_scheme where
  "free_tv_ML (FVar m) = [m]"
| "free_tv_ML (BVar m) = []"
| "free_tv_ML (S1 =-> S2) = (free_tv_ML S1) @ (free_tv_ML S2)"

primrec bound_tv_type_scheme where
  "bound_tv (FVar m) = {}"
| "bound_tv (BVar m) = {m}"
| "bound_tv (S1 =-> S2) = (bound_tv S1) Un (bound_tv S2)"

primrec min_new_bound_tv_type_scheme where
  "min_new_bound_tv (FVar n) = 0"
| "min_new_bound_tv (BVar n) = Suc n"
| "min_new_bound_tv (sch1 =-> sch2) = max (min_new_bound_tv sch1) (min_new_bound_tv sch2)"

primrec app_subst_type_scheme where
  "$ S (FVar n) = mk_scheme (S n)"
| "$ S (BVar n) = (BVar n)"
| "$ S (sch1 =-> sch2) = ($ S sch1) =-> ($ S sch2)"

instance ..

end

instantiation list :: (type_struct) type_struct
begin

primrec free_tv_list where
  "free_tv [] = {}"
| "free_tv (x#l) = (free_tv x) Un (free_tv l)"

primrec free_tv_ML_list where
  "free_tv_ML [] = []"
| "free_tv_ML (x#l) = (free_tv_ML x) @ (free_tv_ML l)"

primrec bound_tv_list where
  "bound_tv [] = {}"
| "bound_tv (x#l) = (bound_tv x) Un (bound_tv l)"

definition app_subst_list where
  app_subst_list: "$ S = map ($ S)"

instance ..

end

text
\<open>\<open>new_tv s n\<close> computes whether n is a new type variable w.r.t. a type
   structure s, i.e. whether n is greater than any type variable
   occurring in the type structure\<close>
definition
  new_tv :: "[nat,'a::type_struct] => bool" where
  "new_tv n ts = (\<forall>m. m:(free_tv ts) \<longrightarrow> m<n)"

\<comment> \<open>identity\<close>
definition
  id_subst :: subst where
  "id_subst = (\<lambda>n. TVar n)"

\<comment> \<open>domain of a substitution\<close>
definition
  dom :: "subst => nat set" where
  "dom S = {n. S n \<noteq> TVar n}"

\<comment> \<open>codomain of a substitution: the introduced variables\<close>
definition
  cod :: "subst => nat set" where
  "cod S = (UN m:dom S. (free_tv (S m)))"

class of_nat =
  fixes of_nat :: "nat \<Rightarrow> 'a"

instantiation nat :: of_nat
begin

definition
  "of_nat n = n"

instance ..

end

class typ_of =
  fixes typ_of :: "'a \<Rightarrow> typ"

instantiation "typ" :: typ_of
begin

definition
  "typ_of T = T"

instance ..

end

instantiation "fun" :: (of_nat, typ_of) type_struct
begin

definition free_tv_fun where
  "free_tv f = (let S = \<lambda>n. typ_of (f (of_nat n)) in (dom S) Un (cod S))"

instance ..

end

lemma free_tv_subst:
  "free_tv S = (dom S) Un (cod S)"
  by (simp add: free_tv_fun_def of_nat_nat_def typ_of_typ_def )

\<comment> \<open>unification algorithm mgu\<close>
axiomatization mgu :: "typ \<Rightarrow> typ \<Rightarrow> subst option" where
  mgu_eq:   "mgu t1 t2 = Some U \<Longrightarrow> $U t1 = $U t2"
  and mgu_mg:   "[| (mgu t1 t2) = Some U; $S t1 = $S t2 |] ==> \<exists>R. S = $R \<circ> U"
  and mgu_Some: "$S t1 = $S t2 \<Longrightarrow> \<exists>U. mgu t1 t2 = Some U"
  and mgu_free: "mgu t1 t2 = Some U \<Longrightarrow> (free_tv U) \<subseteq> (free_tv t1) Un (free_tv t2)"

declare mgu_eq [simp] mgu_mg [simp] mgu_free [simp]
lemma mk_scheme_Fun [rule_format]: "mk_scheme t = sch1 =-> sch2 \<longrightarrow> (\<exists>t1 t2. sch1 = mk_scheme t1 \<and> sch2 = mk_scheme t2)"
apply (induct_tac "t")
apply (simp (no_asm))
apply simp
apply fast
done

lemma mk_scheme_injective [rule_format]: "\<forall>t'. mk_scheme t = mk_scheme t' \<longrightarrow> t=t'"
apply (induct_tac "t")
 apply (rule allI)
 apply (induct_tac "t'")
  apply (simp (no_asm))
 apply simp
apply (rule allI)
apply (induct_tac "t'")
 apply (simp (no_asm))
apply simp
done

lemma free_tv_mk_scheme: "free_tv (mk_scheme t) = free_tv t"
apply (induct_tac "t")
apply (simp_all (no_asm_simp))
done

declare free_tv_mk_scheme [simp]

lemma subst_mk_scheme: "$ S (mk_scheme t) = mk_scheme ($ S t)"
apply (induct_tac "t")
apply (simp_all (no_asm_simp))
done

declare subst_mk_scheme [simp]

\<comment> \<open>constructor laws for @{text app_subst}\<close>

lemma app_subst_Nil:
  "$ S [] = []"

apply (unfold app_subst_list)
apply (simp (no_asm))
done

declare app_subst_Nil [simp] app_subst_Cons [simp]

\<comment> \<open>constructor laws for @{text new_tv}\<close>

lemma new_tv_TVar:
  "new_tv n (TVar m) = (m<n)"

apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_FVar:
  "new_tv n (FVar m) = (m<n)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_BVar:
  "new_tv n (BVar m) = True"
apply (unfold new_tv_def)
apply (simp (no_asm))
done

lemma new_tv_Fun:
  "new_tv n (t1 -> t2) = (new_tv n t1 \<and> new_tv n t2)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_Fun2:
  "new_tv n (t1 =-> t2) = (new_tv n t1 \<and> new_tv n t2)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_Nil:
  "new_tv n []"
apply (unfold new_tv_def)
apply (simp (no_asm))
done

lemma new_tv_Cons:
  "new_tv n (x#l) = (new_tv n x \<and> new_tv n l)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_TVar_subst: "new_tv n TVar"
apply (unfold new_tv_def)
apply (intro strip)
apply (simp add: free_tv_subst dom_def cod_def)
done

declare
  new_tv_TVar [simp] new_tv_FVar [simp] new_tv_BVar [simp]
  new_tv_Fun [simp] new_tv_Fun2 [simp] new_tv_Nil [simp]
  new_tv_Cons [simp] new_tv_TVar_subst [simp]

lemma new_tv_id_subst [simp]: "new_tv n id_subst"
  by (simp add: id_subst_def new_tv_def free_tv_subst dom_def cod_def)

lemma new_if_subst_type_scheme [simp]: "new_tv n (sch::type_scheme) \<Longrightarrow>
    $(\<lambda>k. if k<n then S k else S' k) sch = $S sch"
  by (induct sch) simp_all

lemma new_if_subst_type_scheme_list [simp]: "new_tv n (A::type_scheme list) \<Longrightarrow>
    $(\<lambda>k. if k<n then S k else S' k) A = $S A"
  by (induct A) simp_all

\<comment> \<open>constructor laws for @{text dom} and @{text cod}\<close>

lemma dom_id_subst [simp]: "dom id_subst = {}"
  unfolding dom_def id_subst_def empty_def by simp

lemma cod_id_subst [simp]: "cod id_subst = {}"
  unfolding cod_def by simp

lemma free_tv_id_subst [simp]: "free_tv id_subst = {}"
  unfolding free_tv_subst by simp

lemma free_tv_nth_A_impl_free_tv_A [rule_format, simp]:
  "\<forall>n. n < length A \<longrightarrow> x : free_tv (A!n) \<longrightarrow> x : free_tv A"
apply (induct A)
apply simp
apply (rule allI)
apply (induct_tac n)
apply simp
apply simp
done

text
\<open>if two substitutions yield the same result if applied to a type
   structure the substitutions coincide on the free type variables
   occurring in the type structure\<close>

lemma typ_substitutions_only_on_free_variables:
  "(\<forall>x\<in>free_tv t. (S x) = (S' x)) \<Longrightarrow> $ S (t::typ) = $ S' t"
  by (induct t) simp_all

lemma eq_free_eq_subst_te: "(\<forall>n. n\<in>(free_tv t) \<longrightarrow> S1 n = S2 n) \<Longrightarrow> $ S1 (t::typ) = $ S2 t"
apply (rule typ_substitutions_only_on_free_variables)
apply simp
done

lemma scheme_substitutions_only_on_free_variables:
  "(\<forall>x\<in>free_tv sch. (S x) = (S' x)) \<Longrightarrow> $ S (sch::type_scheme) = $ S' sch"
  by (induct sch) simp_all

lemma eq_free_eq_subst_type_scheme:
  "(\<forall>n. n\<in>(free_tv sch) \<longrightarrow> S1 n = S2 n) \<Longrightarrow> $ S1 (sch::type_scheme) = $ S2 sch"
apply (rule scheme_substitutions_only_on_free_variables)
apply simp
done

lemma weaken_asm_Un: "((\<forall>x\<in>A. (P x)) \<longrightarrow> Q) \<Longrightarrow> ((\<forall>x\<in>A \<union> B. (P x)) \<longrightarrow> Q)"
  by fast

lemma scheme_list_substitutions_only_on_free_variables [rule_format]:
  "(\<forall>x\<in>free_tv A. (S x) = (S' x)) \<longrightarrow> $ S (A::type_scheme list) = $ S' A"
apply (induct_tac A)
apply simp
apply simp
apply (rule weaken_asm_Un)
apply (intro strip)
apply (erule scheme_substitutions_only_on_free_variables)
done

lemma eq_subst_te_eq_free:
  "$ S1 (t::typ) = $ S2 t \<Longrightarrow> n:(free_tv t) \<Longrightarrow> S1 n = S2 n"
  by (induct t) auto

lemma eq_subst_type_scheme_eq_free [rule_format]:
  "$ S1 (sch::type_scheme) = $ S2 sch \<longrightarrow> n:(free_tv sch) \<longrightarrow> S1 n = S2 n"
apply (induct_tac "sch")
(* case TVar n *)
apply simp
(* case BVar n *)
apply (intro strip)
apply (erule mk_scheme_injective)
apply simp
(* case Fun t1 t2 *)
apply simp
done

lemma eq_subst_scheme_list_eq_free:
  "$S1 (A::type_scheme list) = $S2 A \<Longrightarrow> n:(free_tv A) \<Longrightarrow> S1 n = S2 n"
proof (induct A)
  case Nil
  then show ?case by fastforce
next
  case Cons
  then show ?case by (fastforce intro: eq_subst_type_scheme_eq_free)
qed

lemma codD: "v : cod S \<Longrightarrow> v : free_tv S"
  unfolding free_tv_subst by blast

lemma not_free_impl_id: "x \<notin> free_tv S \<Longrightarrow> S x = TVar x"
  unfolding free_tv_subst dom_def by blast

lemma free_tv_le_new_tv: "[| new_tv n t; m:free_tv t |] ==> m<n"
  unfolding new_tv_def by blast

lemma cod_app_subst [simp]:
  "[| v : free_tv(S n); v\<noteq>n |] ==> v : cod S"
apply (unfold dom_def cod_def UNION_eq Bex_def)
apply (simp (no_asm))
apply (safe intro!: exI)
prefer 2 apply (assumption)
apply simp
done

lemma free_tv_subst_var: "free_tv (S (v::nat)) \<subseteq> insert v (cod S)"
apply (cases "v:dom S")
apply (fastforce simp add: cod_def)
apply (fastforce simp add: dom_def)
done

lemma free_tv_app_subst_te: "free_tv ($ S (t::typ)) \<subseteq> cod S Un free_tv t"
proof (induct t)
  case (TVar n) then show ?case by (simp add: free_tv_subst_var)
next
  case (Fun t1 t2) then show ?case by fastforce
qed

lemma free_tv_app_subst_type_scheme:
    "free_tv ($ S (sch::type_scheme)) \<subseteq> cod S Un free_tv sch"
proof (induct sch)
  case (FVar n)
  then show ?case by (simp add: free_tv_subst_var)
next
  case (BVar n)
  then show ?case by simp
next
  case (SFun t1 t2)
  then show ?case by fastforce
qed

lemma free_tv_app_subst_scheme_list: "free_tv ($ S (A::type_scheme list)) \<subseteq> cod S Un free_tv A"
proof (induct A)
  case Nil then show ?case by simp
next
  case (Cons a al)
  with free_tv_app_subst_type_scheme
  show ?case by fastforce
qed

lemma free_tv_comp_subst:
  "free_tv (\<lambda>u::nat. $ s1 (s2 u) :: typ) \<subseteq>
    free_tv s1 Un free_tv s2"
  unfolding free_tv_subst dom_def
  by (force simp add: cod_def dom_def
    dest!:free_tv_app_subst_te [THEN subsetD])

lemma free_tv_o_subst:
    "free_tv ($ S1 \<circ> S2) \<subseteq> free_tv S1 Un free_tv (S2 :: nat => typ)"
  unfolding o_def by (rule free_tv_comp_subst)

lemma free_tv_of_substitutions_extend_to_types:
    "n : free_tv t \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S t::typ)"
  by (induct t) auto

lemma free_tv_of_substitutions_extend_to_schemes:
    "n : free_tv sch \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S sch::type_scheme)"
  by (induct sch) auto

lemma free_tv_of_substitutions_extend_to_scheme_lists [simp]:
    "n : free_tv A \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S A::type_scheme list)"
  by (induct A) (auto dest: free_tv_of_substitutions_extend_to_schemes)

lemma free_tv_ML_scheme:
  fixes sch :: type_scheme
  shows "(n : free_tv sch) = (n: set (free_tv_ML sch))"
  by (induct sch) simp_all

lemma free_tv_ML_scheme_list:
  fixes A :: "type_scheme list"
  shows "(n : free_tv A) = (n: set (free_tv_ML A))"
  by (induct_tac A) (simp_all add: free_tv_ML_scheme)

\<comment> \<open>lemmata for @{text bound_tv}\<close>

lemma bound_tv_mk_scheme [simp]: "bound_tv (mk_scheme t) = {}"
  by (induct t) simp_all

lemma bound_tv_subst_scheme [simp]:
  fixes sch :: type_scheme
  shows "bound_tv ($ S sch) = bound_tv sch"
  by (induct sch) simp_all

lemma bound_tv_subst_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "bound_tv ($ S A) = bound_tv A"
  by (induct A) simp_all

\<comment> \<open>lemmata for @{text new_tv}\<close>

lemma new_tv_subst:
  "new_tv n S = ((\<forall>m. n \<le> m \<longrightarrow> (S m = TVar m)) \<and>
                 (\<forall>l. l < n \<longrightarrow> new_tv n (S l) ))"

apply (unfold new_tv_def)
apply (safe)
  (* ==> *)
  apply (fastforce dest: leD simp add: free_tv_subst dom_def)
 apply (subgoal_tac "m:cod S | S l = TVar l")
  apply safe
   apply (fastforce dest: UnI2 simp add: free_tv_subst)
  apply (drule_tac P = "\<lambda>x. m:free_tv x" in subst , assumption)
  apply simp
 apply (fastforce simp add: free_tv_subst cod_def dom_def)
(* <== *)
apply (unfold free_tv_subst cod_def dom_def)
apply safe
apply (metis not_le_imp_less)+
done

lemma new_tv_list: "new_tv n x = (\<forall>y\<in>set x. new_tv n y)"
  by (induct x) simp_all

\<comment> \<open>substitution affects only variables occurring freely\<close>
lemma subst_te_new_tv [simp]:
    "new_tv n (t::typ) \<longrightarrow> $(\<lambda>x. if x=n then t' else S x) t = $S t"
  by (induct t) simp_all

lemma subst_te_new_type_scheme [simp]:
    "new_tv n (sch::type_scheme) \<Longrightarrow> $(\<lambda>x. if x=n then sch' else S x) sch = $S sch"
  by (induct sch) simp_all

lemma subst_tel_new_scheme_list [simp]:
    "new_tv n (A::type_scheme list) \<Longrightarrow> $(\<lambda>x. if x=n then t else S x) A = $S A"
  by (induct A) simp_all

\<comment> \<open>all greater variables are also new\<close>
lemma new_tv_le:
  "n\<le>m \<Longrightarrow> new_tv n t \<Longrightarrow> new_tv m t"
apply (unfold new_tv_def)
apply safe
apply (drule spec)
apply (erule (1) notE impE)
apply (simp (no_asm))
done

lemma new_tv_typ_le: "n\<le>m \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv m t"
  by (simp add: new_tv_le)

lemma new_scheme_list_le: "n\<le>m \<Longrightarrow> new_tv n (A::type_scheme list) \<Longrightarrow> new_tv m A"
  by (simp add: new_tv_le)

lemma new_tv_subst_le: "n\<le>m \<Longrightarrow> new_tv n (S::subst) \<Longrightarrow> new_tv m S"
  by (simp add: new_tv_le)

\<comment> \<open>@{text new_tv} property remains if a substitution is applied\<close>
lemma new_tv_subst_var:
  "[| n<m; new_tv m (S::subst) |] ==> new_tv m (S n)"
  by (simp add: new_tv_subst)

lemma new_tv_subst_te [simp]:
    "new_tv n S \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv n ($ S t)"
  by (induct t) (auto simp add: new_tv_subst)

lemma new_tv_subst_type_scheme [rule_format, simp]:
  "new_tv n S \<longrightarrow> new_tv n (sch::type_scheme) \<longrightarrow> new_tv n ($ S sch)"
apply (induct sch)
apply (simp_all)
apply (unfold new_tv_def)
apply (simp (no_asm) add: free_tv_subst dom_def cod_def)
apply (intro strip)
apply (rename_tac nat m)
apply (case_tac "S nat = TVar nat")
apply simp
apply (drule_tac x = "m" in spec)
apply fast
done

lemma new_tv_subst_scheme_list [simp]:
    "new_tv n S \<Longrightarrow> new_tv n (A::type_scheme list) \<Longrightarrow> new_tv n ($ S A)"
  by (induct A) auto

lemma new_tv_Suc_list: "new_tv n A \<longrightarrow> new_tv (Suc n) ((TVar n)#A)"
  by (simp add: new_tv_list)

lemma new_tv_only_depends_on_free_tv_type_scheme:
  fixes sch :: type_scheme
  shows "free_tv sch = free_tv sch' \<Longrightarrow> new_tv n sch \<Longrightarrow> new_tv n sch'"
  unfolding new_tv_def by simp

lemma new_tv_only_depends_on_free_tv_scheme_list:
  fixes A :: "type_scheme list"
  shows "free_tv A = free_tv A' \<Longrightarrow> new_tv n A \<Longrightarrow> new_tv n A'"
  unfolding new_tv_def by simp

lemma new_tv_nth_nat_A [rule_format]:
  "\<forall>nat. nat < length A \<longrightarrow> new_tv n A \<longrightarrow> (new_tv n (A!nat))"
apply (unfold new_tv_def)
apply (induct A)
apply simp
apply (rule allI)
apply (induct_tac "nat")
apply (intro strip)
apply simp
apply (simp (no_asm))
done

\<comment> \<open>composition of substitutions preserves @{text new_tv} proposition\<close>
lemma new_tv_subst_comp_1 [simp]:
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (($ R) \<circ> S)"
  by (simp add: new_tv_subst)

lemma new_tv_subst_comp_2 [simp]:
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (\<lambda>v.$ R (S v))"
  by (simp add: new_tv_subst)

\<comment> \<open>new type variables do not occur freely in a type structure\<close>
lemma new_tv_not_free_tv [simp]:
    "new_tv n A \<Longrightarrow> n\<notin>(free_tv A)"
  by (auto simp add: new_tv_def)

lemma fresh_variable_types [simp]: "\<And>t::typ. \<exists>n. (new_tv n t)"
apply (unfold new_tv_def)
apply (induct_tac t)
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm_simp))
apply (erule exE)+
apply (rename_tac "n'")
apply (rule_tac x = "max n n'" in exI)
apply (simp add: less_max_iff_disj)
done

lemma fresh_variable_type_schemes [simp]:
  "\<And>sch::type_scheme. \<exists>n. (new_tv n sch)"
apply (unfold new_tv_def)
apply (induct_tac sch)
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm))
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm))
apply (erule exE)+
apply (rename_tac "n'")
apply (rule_tac x = "max n n'" in exI)
apply (simp add: less_max_iff_disj)
done

lemma fresh_variable_type_scheme_lists [simp]:
  "\<And>A::type_scheme list. \<exists>n. (new_tv n A)"
apply (induct_tac A)
apply (simp (no_asm))
apply (simp (no_asm))
apply (erule exE)
apply (cut_tac sch = "a" in fresh_variable_type_schemes)
apply (erule exE)
apply (rename_tac "n'")
apply (rule_tac x = " (max n n') " in exI)
apply (subgoal_tac "n \<le> (max n n') ")
apply (subgoal_tac "n' \<le> (max n n') ")
apply (fast dest: new_tv_le)
apply (simp_all add: le_max_iff_disj)
done

lemma make_one_new_out_of_two:
  "[| \<exists>n1. (new_tv n1 x); \<exists>n2. (new_tv n2 y)|] ==> \<exists>n. (new_tv n x) \<and> (new_tv n y)"
apply (erule exE)+
apply (rename_tac "n1" "n2")
apply (rule_tac x = " (max n1 n2) " in exI)
apply (subgoal_tac "n1 \<le> max n1 n2")
apply (subgoal_tac "n2 \<le> max n1 n2")
apply (fast dest: new_tv_le)
apply (simp_all (no_asm) add: le_max_iff_disj)
done

lemma ex_fresh_variable:
  "\<And>(A::type_scheme list) (A'::type_scheme list) (t::typ) (t'::typ).
          \<exists>n. (new_tv n A) \<and> (new_tv n A') \<and> (new_tv n t) \<and> (new_tv n t')"
apply (cut_tac t = "t" in fresh_variable_types)
apply (cut_tac t = "t'" in fresh_variable_types)
apply (drule make_one_new_out_of_two)
apply assumption
apply (erule_tac V = "\<exists>n. new_tv n t'" in thin_rl)
apply (cut_tac A = "A" in fresh_variable_type_scheme_lists)
apply (cut_tac A = "A'" in fresh_variable_type_scheme_lists)
apply (rotate_tac 1)
apply (drule make_one_new_out_of_two)
apply assumption
apply (erule_tac V = "\<exists>n. new_tv n A'" in thin_rl)
apply (erule exE)+
apply (rename_tac n2 n1)
apply (rule_tac x = " (max n1 n2) " in exI)
apply (unfold new_tv_def)
apply (simp (no_asm) add: less_max_iff_disj)
apply blast
done

\<comment> \<open>mgu does not introduce new type variables\<close>
lemma mgu_new:
      "[|mgu t1 t2 = Some u; new_tv n t1; new_tv n t2|] ==> new_tv n u"
apply (unfold new_tv_def)
apply (fast dest: mgu_free)
done

(* lemmata for substitutions *)

lemma length_app_subst_list [simp]:
   "\<And>A:: ('a::type_struct) list. length ($ S A) = length A"
  unfolding app_subst_list by simp

lemma subst_TVar_scheme [simp]:
  fixes sch :: type_scheme
  shows "$ TVar sch = sch"
  by (induct sch) simp_all

lemma subst_TVar_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "$ TVar A = A"
  by (induct A) (simp_all add: app_subst_list)

\<comment> \<open>application of @{text id_subst} does not change type expression\<close>
lemma app_subst_id_te [simp]: "$ id_subst = (\<lambda>t::typ. t)"
apply (unfold id_subst_def)
apply (rule ext)
apply (induct_tac "t")
apply simp_all
done

lemma app_subst_id_type_scheme [simp]:
  "$ id_subst = (\<lambda>sch::type_scheme. sch)"
apply (unfold id_subst_def)
apply (rule ext)
apply (induct_tac "sch")
apply simp_all
done

\<comment> \<open>application of @{text id_subst} does not change list of type expressions\<close>
lemma app_subst_id_tel [simp]:
  "$ id_subst = (\<lambda>A::type_scheme list. A)"
apply (unfold app_subst_list)
apply (rule ext)
apply (induct_tac "A")
apply simp_all
done

lemma id_subst_sch [simp]:
  fixes sch :: type_scheme
  shows "$ id_subst sch = sch"
  by (induct sch) (simp_all add: id_subst_def)

lemma id_subst_A [simp]:
  fixes A :: "type_scheme list"
  shows "$ id_subst A = A"
  by (induct A) simp_all

\<comment> \<open>composition of substitutions\<close>
lemma o_id_subst [simp]: "$S \<circ> id_subst = S"
  unfolding id_subst_def o_def by simp

lemma subst_comp_te: "$ R ($ S t::typ) = $ (\<lambda>x. $ R (S x) ) t"
  by (induct t) simp_all

lemma subst_comp_type_scheme:
  "$ R ($ S sch::type_scheme) = $ (\<lambda>x. $ R (S x) ) sch"
  by (induct sch) simp_all

lemma subst_comp_scheme_list:
  "$ R ($ S A::type_scheme list) = $ (\<lambda>x. $ R (S x)) A"
unfolding app_subst_list
proof (induct A)
  case Nil then show ?case by simp
next
  case (Cons x xl)
  then show ?case by (simp add: subst_comp_type_scheme)
qed

lemma subst_id_on_type_scheme_list':
  fixes A :: "type_scheme list"
  shows "\<forall>x \<in> free_tv A. S x = (TVar x) \<Longrightarrow> $ S A = $ id_subst A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: id_subst_def)
done

lemma subst_id_on_type_scheme_list:
  fixes A :: "type_scheme list"
  shows "\<forall>x \<in> free_tv A. S x = (TVar x) \<Longrightarrow> $ S A = A"
apply (subst subst_id_on_type_scheme_list')
apply assumption
apply simp
done

lemma nth_subst [rule_format]:
  "\<forall>n. n < length A \<longrightarrow> ($ S A)!n = $S (A!n)"
apply (induct A)
apply simp
apply (rule allI)
apply (rename_tac "n1")
apply (induct_tac "n1")
apply simp
apply simp
done

end


(*  Title:      HOL/Hahn_Banach/Hahn_Banach.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>The Hahn-Banach Theorem\<close>

theory Hahn_Banach
imports Hahn_Banach_Lemmas
begin

text \<open>
  We present the proof of two different versions of the Hahn-Banach Theorem,
  closely following @{cite \<open>\S36\<close> "Heuser:1986"}.
\<close>

subsection \<open>The Hahn-Banach Theorem for vector spaces\<close>

paragraph \<open>Hahn-Banach Theorem.\<close>
text \<open>
  Let \<open>F\<close> be a subspace of a real vector space \<open>E\<close>, let \<open>p\<close> be a semi-norm on
  \<open>E\<close>, and \<open>f\<close> be a linear form defined on \<open>F\<close> such that \<open>f\<close> is bounded by
  \<open>p\<close>, i.e. \<open>\<forall>x \<in> F. f x \<le> p x\<close>. Then \<open>f\<close> can be extended to a linear form \<open>h\<close>
  on \<open>E\<close> such that \<open>h\<close> is norm-preserving, i.e. \<open>h\<close> is also bounded by \<open>p\<close>.
\<close>

paragraph \<open>Proof Sketch.\<close>
text \<open>
  \<^enum> Define \<open>M\<close> as the set of norm-preserving extensions of \<open>f\<close> to subspaces of
  \<open>E\<close>. The linear forms in \<open>M\<close> are ordered by domain extension.

  \<^enum> We show that every non-empty chain in \<open>M\<close> has an upper bound in \<open>M\<close>.

  \<^enum> With Zorn's Lemma we conclude that there is a maximal function \<open>g\<close> in \<open>M\<close>.

  \<^enum> The domain \<open>H\<close> of \<open>g\<close> is the whole space \<open>E\<close>, as shown by classical
  contradiction:

    \<^item> Assuming \<open>g\<close> is not defined on whole \<open>E\<close>, it can still be extended in a
    norm-preserving way to a super-space \<open>H'\<close> of \<open>H\<close>.

    \<^item> Thus \<open>g\<close> can not be maximal. Contradiction!
\<close>

theorem Hahn_Banach:
  assumes E: "vectorspace E" and "subspace F E"
    and "seminorm E p" and "linearform F f"
  assumes fp: "\<forall>x \<in> F. f x \<le> p x"
  shows "\<exists>h. linearform E h \<and> (\<forall>x \<in> F. h x = f x) \<and> (\<forall>x \<in> E. h x \<le> p x)"
    \<comment> \<open>Let \<open>E\<close> be a vector space, \<open>F\<close> a subspace of \<open>E\<close>, \<open>p\<close> a seminorm on \<open>E\<close>,\<close>
    \<comment> \<open>and \<open>f\<close> a linear form on \<open>F\<close> such that \<open>f\<close> is bounded by \<open>p\<close>,\<close>
    \<comment> \<open>then \<open>f\<close> can be extended to a linear form \<open>h\<close> on \<open>E\<close> in a norm-preserving way. \<^smallskip>\<close>
proof -
  interpret vectorspace E by fact
  interpret subspace F E by fact
  interpret seminorm E p by fact
  interpret linearform F f by fact
  define M where "M = norm_pres_extensions E p F f"
  then have M: "M = \<dots>" by (simp only:)
  from E have F: "vectorspace F" ..
  note FE = \<open>F \<unlhd> E\<close>
  {
    fix c assume cM: "c \<in> chains M" and ex: "\<exists>x. x \<in> c"
    have "\<Union>c \<in> M"
      \<comment> \<open>Show that every non-empty chain \<open>c\<close> of \<open>M\<close> has an upper bound in \<open>M\<close>:\<close>
      \<comment> \<open>\<open>\<Union>c\<close> is greater than any element of the chain \<open>c\<close>, so it suffices to show \<open>\<Union>c \<in> M\<close>.\<close>
      unfolding M_def
    proof (rule norm_pres_extensionI)
      let ?H = "domain (\<Union>c)"
      let ?h = "funct (\<Union>c)"

      have a: "graph ?H ?h = \<Union>c"
      proof (rule graph_domain_funct)
        fix x y z assume "(x, y) \<in> \<Union>c" and "(x, z) \<in> \<Union>c"
        with M_def cM show "z = y" by (rule sup_definite)
      qed
      moreover from M cM a have "linearform ?H ?h"
        by (rule sup_lf)
      moreover from a M cM ex FE E have "?H \<unlhd> E"
        by (rule sup_subE)
      moreover from a M cM ex FE have "F \<unlhd> ?H"
        by (rule sup_supF)
      moreover from a M cM ex have "graph F f \<subseteq> graph ?H ?h"
        by (rule sup_ext)
      moreover from a M cM have "\<forall>x \<in> ?H. ?h x \<le> p x"
        by (rule sup_norm_pres)
      ultimately show "\<exists>H h. \<Union>c = graph H h
          \<and> linearform H h
          \<and> H \<unlhd> E
          \<and> F \<unlhd> H
          \<and> graph F f \<subseteq> graph H h
          \<and> (\<forall>x \<in> H. h x \<le> p x)" by blast
    qed
  }
  then have "\<exists>g \<in> M. \<forall>x \<in> M. g \<subseteq> x \<longrightarrow> x = g"
  \<comment> \<open>With Zorn's Lemma we can conclude that there is a maximal element in \<open>M\<close>. \<^smallskip>\<close>
  proof (rule Zorn's_Lemma)
      \<comment> \<open>We show that \<open>M\<close> is non-empty:\<close>
    show "graph F f \<in> M"
      unfolding M_def
    proof (rule norm_pres_extensionI2)
      show "linearform F f" by fact
      show "F \<unlhd> E" by fact
      from F show "F \<unlhd> F" by (rule vectorspace.subspace_refl)
      show "graph F f \<subseteq> graph F f" ..
      show "\<forall>x\<in>F. f x \<le> p x" by fact
    qed
  qed
  then obtain g where gM: "g \<in> M" and gx: "\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x"
    by blast
  from gM obtain H h where
      g_rep: "g = graph H h"
    and linearform: "linearform H h"
    and HE: "H \<unlhd> E" and FH: "F \<unlhd> H"
    and graphs: "graph F f \<subseteq> graph H h"
    and hp: "\<forall>x \<in> H. h x \<le> p x" unfolding M_def ..
      \<comment> \<open>\<open>g\<close> is a norm-preserving extension of \<open>f\<close>, in other words:\<close>
      \<comment> \<open>\<open>g\<close> is the graph of some linear form \<open>h\<close> defined on a subspace \<open>H\<close> of \<open>E\<close>,\<close>
      \<comment> \<open>and \<open>h\<close> is an extension of \<open>f\<close> that is again bounded by \<open>p\<close>. \<^smallskip>\<close>
  from HE E have H: "vectorspace H"
    by (rule subspace.vectorspace)

  have HE_eq: "H = E"
    \<comment> \<open>We show that \<open>h\<close> is defined on whole \<open>E\<close> by classical contradiction. \<^smallskip>\<close>
  proof (rule classical)
    assume neq: "H \<noteq> E"
      \<comment> \<open>Assume \<open>h\<close> is not defined on whole \<open>E\<close>. Then show that \<open>h\<close> can be extended\<close>
      \<comment> \<open>in a norm-preserving way to a function \<open>h'\<close> with the graph \<open>g'\<close>. \<^smallskip>\<close>
    have "\<exists>g' \<in> M. g \<subseteq> g' \<and> g \<noteq> g'"
    proof -
      from HE have "H \<subseteq> E" ..
      with neq obtain x' where x'E: "x' \<in> E" and "x' \<notin> H" by blast
      obtain x': "x' \<noteq> 0"
      proof
        show "x' \<noteq> 0"
        proof
          assume "x' = 0"
          with H have "x' \<in> H" by (simp only: vectorspace.zero)
          with \<open>x' \<notin> H\<close> show False by contradiction
        qed
      qed

      define H' where "H' = H + lin x'"
        \<comment> \<open>Define \<open>H'\<close> as the direct sum of \<open>H\<close> and the linear closure of \<open>x'\<close>. \<^smallskip>\<close>
      have HH': "H \<unlhd> H'"
      proof (unfold H'_def)
        from x'E have "vectorspace (lin x')" ..
        with H show "H \<unlhd> H + lin x'" ..
      qed

      obtain xi where
        xi: "\<forall>y \<in> H. - p (y + x') - h y \<le> xi
          \<and> xi \<le> p (y + x') - h y"
        \<comment> \<open>Pick a real number \<open>\<xi>\<close> that fulfills certain inequality; this will\<close>
        \<comment> \<open>be used to establish that \<open>h'\<close> is a norm-preserving extension of \<open>h\<close>.
           \label{ex-xi-use}\<^smallskip>\<close>
      proof -
        from H have "\<exists>xi. \<forall>y \<in> H. - p (y + x') - h y \<le> xi
            \<and> xi \<le> p (y + x') - h y"
        proof (rule ex_xi)
          fix u v assume u: "u \<in> H" and v: "v \<in> H"
          with HE have uE: "u \<in> E" and vE: "v \<in> E" by auto
          from H u v linearform have "h v - h u = h (v - u)"
            by (simp add: linearform.diff)
          also from hp and H u v have "\<dots> \<le> p (v - u)"
            by (simp only: vectorspace.diff_closed)
          also from x'E uE vE have "v - u = x' + - x' + v + - u"
            by (simp add: diff_eq1)
          also from x'E uE vE have "\<dots> = v + x' + - (u + x')"
            by (simp add: add_ac)
          also from x'E uE vE have "\<dots> = (v + x') - (u + x')"
            by (simp add: diff_eq1)
          also from x'E uE vE E have "p \<dots> \<le> p (v + x') + p (u + x')"
            by (simp add: diff_subadditive)
          finally have "h v - h u \<le> p (v + x') + p (u + x')" .
          then show "- p (u + x') - h u \<le> p (v + x') - h v" by simp
        qed
        then show thesis by (blast intro: that)
      qed

      define h' where "h' x = (let (y, a) =
          SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H in h y + a * xi)" for x
        \<comment> \<open>Define the extension \<open>h'\<close> of \<open>h\<close> to \<open>H'\<close> using \<open>\<xi>\<close>. \<^smallskip>\<close>

      have "g \<subseteq> graph H' h' \<and> g \<noteq> graph H' h'"
        \<comment> \<open>\<open>h'\<close> is an extension of \<open>h\<close> \dots \<^smallskip>\<close>
      proof
        show "g \<subseteq> graph H' h'"
        proof -
          have "graph H h \<subseteq> graph H' h'"
          proof (rule graph_extI)
            fix t assume t: "t \<in> H"
            from E HE t have "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
              using \<open>x' \<notin> H\<close> \<open>x' \<in> E\<close> \<open>x' \<noteq> 0\<close> by (rule decomp_H'_H)
            with h'_def show "h t = h' t" by (simp add: Let_def)
          next
            from HH' show "H \<subseteq> H'" ..
          qed
          with g_rep show ?thesis by (simp only:)
        qed

        show "g \<noteq> graph H' h'"
        proof -
          have "graph H h \<noteq> graph H' h'"
          proof
            assume eq: "graph H h = graph H' h'"
            have "x' \<in> H'"
              unfolding H'_def
            proof
              from H show "0 \<in> H" by (rule vectorspace.zero)
              from x'E show "x' \<in> lin x'" by (rule x_lin_x)
              from x'E show "x' = 0 + x'" by simp
            qed
            then have "(x', h' x') \<in> graph H' h'" ..
            with eq have "(x', h' x') \<in> graph H h" by (simp only:)
            then have "x' \<in> H" ..
            with \<open>x' \<notin> H\<close> show False by contradiction
          qed
          with g_rep show ?thesis by simp
        qed
      qed
      moreover have "graph H' h' \<in> M"
        \<comment> \<open>and \<open>h'\<close> is norm-preserving. \<^smallskip>\<close>
      proof (unfold M_def)
        show "graph H' h' \<in> norm_pres_extensions E p F f"
        proof (rule norm_pres_extensionI2)
          show "linearform H' h'"
            using h'_def H'_def HE linearform \<open>x' \<notin> H\<close> \<open>x' \<in> E\<close> \<open>x' \<noteq> 0\<close> E
            by (rule h'_lf)
          show "H' \<unlhd> E"
          unfolding H'_def
          proof
            show "H \<unlhd> E" by fact
            show "vectorspace E" by fact
            from x'E show "lin x' \<unlhd> E" ..
          qed
          from H \<open>F \<unlhd> H\<close> HH' show FH': "F \<unlhd> H'"
            by (rule vectorspace.subspace_trans)
          show "graph F f \<subseteq> graph H' h'"
          proof (rule graph_extI)
            fix x assume x: "x \<in> F"
            with graphs have "f x = h x" ..
            also have "\<dots> = h x + 0 * xi" by simp
            also have "\<dots> = (let (y, a) = (x, 0) in h y + a * xi)"
              by (simp add: Let_def)
            also have "(x, 0) =
                (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)"
              using E HE
            proof (rule decomp_H'_H [symmetric])
              from FH x show "x \<in> H" ..
              from x' show "x' \<noteq> 0" .
              show "x' \<notin> H" by fact
              show "x' \<in> E" by fact
            qed
            also have
              "(let (y, a) = (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)
              in h y + a * xi) = h' x" by (simp only: h'_def)
            finally show "f x = h' x" .
          next
            from FH' show "F \<subseteq> H'" ..
          qed
          show "\<forall>x \<in> H'. h' x \<le> p x"
            using h'_def H'_def \<open>x' \<notin> H\<close> \<open>x' \<in> E\<close> \<open>x' \<noteq> 0\<close> E HE
              \<open>seminorm E p\<close> linearform and hp xi
            by (rule h'_norm_pres)
        qed
      qed
      ultimately show ?thesis ..
    qed
    then have "\<not> (\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x)" by simp
      \<comment> \<open>So the graph \<open>g\<close> of \<open>h\<close> cannot be maximal. Contradiction! \<^smallskip>\<close>
    with gx show "H = E" by contradiction
  qed

  from HE_eq and linearform have "linearform E h"
    by (simp only:)
  moreover have "\<forall>x \<in> F. h x = f x"
  proof
    fix x assume "x \<in> F"
    with graphs have "f x = h x" ..
    then show "h x = f x" ..
  qed
  moreover from HE_eq and hp have "\<forall>x \<in> E. h x \<le> p x"
    by (simp only:)
  ultimately show ?thesis by blast
qed

subsection \<open>Alternative formulation\<close>

text \<open>
  The following alternative formulation of the Hahn-Banach
  Theorem\label{abs-Hahn-Banach} uses the fact that for a real linear form \<open>f\<close>
  and a seminorm \<open>p\<close> the following inequality are equivalent:\footnote{This
  was shown in lemma @{thm [source] abs_ineq_iff} (see page
  \pageref{abs-ineq-iff}).}
  \begin{center}
  \begin{tabular}{lll}
  \<open>\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x\<close> & and & \<open>\<forall>x \<in> H. h x \<le> p x\<close> \\
  \end{tabular}
  \end{center}
\<close>

theorem abs_Hahn_Banach:
  assumes E: "vectorspace E" and FE: "subspace F E"
    and lf: "linearform F f" and sn: "seminorm E p"
  assumes fp: "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
  shows "\<exists>g. linearform E g
    \<and> (\<forall>x \<in> F. g x = f x)
    \<and> (\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x)"
proof -
  interpret vectorspace E by fact
  interpret subspace F E by fact
  interpret linearform F f by fact
  interpret seminorm E p by fact
  have "\<exists>g. linearform E g \<and> (\<forall>x \<in> F. g x = f x) \<and> (\<forall>x \<in> E. g x \<le> p x)"
    using E FE sn lf
  proof (rule Hahn_Banach)
    show "\<forall>x \<in> F. f x \<le> p x"
      using FE E sn lf and fp by (rule abs_ineq_iff [THEN iffD1])
  qed
  then obtain g where lg: "linearform E g" and *: "\<forall>x \<in> F. g x = f x"
      and **: "\<forall>x \<in> E. g x \<le> p x" by blast
  have "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
    using _ E sn lg **
  proof (rule abs_ineq_iff [THEN iffD2])
    show "E \<unlhd> E" ..
  qed
  with lg * show ?thesis by blast
qed

subsection \<open>The Hahn-Banach Theorem for normed spaces\<close>

text \<open>
  Every continuous linear form \<open>f\<close> on a subspace \<open>F\<close> of a norm space \<open>E\<close>, can
  be extended to a continuous linear form \<open>g\<close> on \<open>E\<close> such that \<open>\<parallel>f\<parallel> = \<parallel>g\<parallel>\<close>.
\<close>

theorem norm_Hahn_Banach:
  fixes V and norm ("\<parallel>_\<parallel>")
  fixes B defines "\<And>V f. B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
  fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
  defines "\<And>V f. \<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"
  assumes E_norm: "normed_vectorspace E norm" and FE: "subspace F E"
    and linearform: "linearform F f" and "continuous F f norm"
  shows "\<exists>g. linearform E g
     \<and> continuous E g norm
     \<and> (\<forall>x \<in> F. g x = f x)
     \<and> \<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
proof -
  interpret normed_vectorspace E norm by fact
  interpret normed_vectorspace_with_fn_norm E norm B fn_norm
    by (auto simp: B_def fn_norm_def) intro_locales
  interpret subspace F E by fact
  interpret linearform F f by fact
  interpret continuous F f norm by fact
  have E: "vectorspace E" by intro_locales
  have F: "vectorspace F" by rule intro_locales
  have F_norm: "normed_vectorspace F norm"
    using FE E_norm by (rule subspace_normed_vs)
  have ge_zero: "0 \<le> \<parallel>f\<parallel>\<hyphen>F"
    by (rule normed_vectorspace_with_fn_norm.fn_norm_ge_zero
      [OF normed_vectorspace_with_fn_norm.intro,
       OF F_norm \<open>continuous F f norm\<close> , folded B_def fn_norm_def])
  txt \<open>We define a function \<open>p\<close> on \<open>E\<close> as follows:
    \<open>p x = \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>\<close>\<close>
  define p where "p x = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>" for x

  txt \<open>\<open>p\<close> is a seminorm on \<open>E\<close>:\<close>
  have q: "seminorm E p"
  proof
    fix x y a assume x: "x \<in> E" and y: "y \<in> E"

    txt \<open>\<open>p\<close> is positive definite:\<close>
    have "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
    moreover from x have "0 \<le> \<parallel>x\<parallel>" ..
    ultimately show "0 \<le> p x"
      by (simp add: p_def zero_le_mult_iff)

    txt \<open>\<open>p\<close> is absolutely homogeneous:\<close>

    show "p (a \<cdot> x) = \<bar>a\<bar> * p x"
    proof -
      have "p (a \<cdot> x) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>a \<cdot> x\<parallel>" by (simp only: p_def)
      also from x have "\<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>" by (rule abs_homogenous)
      also have "\<parallel>f\<parallel>\<hyphen>F * (\<bar>a\<bar> * \<parallel>x\<parallel>) = \<bar>a\<bar> * (\<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>)" by simp
      also have "\<dots> = \<bar>a\<bar> * p x" by (simp only: p_def)
      finally show ?thesis .
    qed

    txt \<open>Furthermore, \<open>p\<close> is subadditive:\<close>

    show "p (x + y) \<le> p x + p y"
    proof -
      have "p (x + y) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel>" by (simp only: p_def)
      also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
      from x y have "\<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>" ..
      with a have " \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>F * (\<parallel>x\<parallel> + \<parallel>y\<parallel>)"
        by (simp add: mult_left_mono)
      also have "\<dots> = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel> + \<parallel>f\<parallel>\<hyphen>F * \<parallel>y\<parallel>" by (simp only: distrib_left)
      also have "\<dots> = p x + p y" by (simp only: p_def)
      finally show ?thesis .
    qed
  qed

  txt \<open>\<open>f\<close> is bounded by \<open>p\<close>.\<close>

  have "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
  proof
    fix x assume "x \<in> F"
    with \<open>continuous F f norm\<close> and linearform
    show "\<bar>f x\<bar> \<le> p x"
      unfolding p_def by (rule normed_vectorspace_with_fn_norm.fn_norm_le_cong
        [OF normed_vectorspace_with_fn_norm.intro,
         OF F_norm, folded B_def fn_norm_def])
  qed

  txt \<open>Using the fact that \<open>p\<close> is a seminorm and \<open>f\<close> is bounded by \<open>p\<close> we can
    apply the Hahn-Banach Theorem for real vector spaces. So \<open>f\<close> can be
    extended in a norm-preserving way to some function \<open>g\<close> on the whole vector
    space \<open>E\<close>.\<close>

  with E FE linearform q obtain g where
      linearformE: "linearform E g"
    and a: "\<forall>x \<in> F. g x = f x"
    and b: "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
    by (rule abs_Hahn_Banach [elim_format]) iprover

  txt \<open>We furthermore have to show that \<open>g\<close> is also continuous:\<close>

  have g_cont: "continuous E g norm" using linearformE
  proof
    fix x assume "x \<in> E"
    with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
      by (simp only: p_def)
  qed

  txt \<open>To complete the proof, we show that \<open>\<parallel>g\<parallel> = \<parallel>f\<parallel>\<close>.\<close>

  have "\<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
  proof (rule order_antisym)
    txt \<open>
      First we show \<open>\<parallel>g\<parallel> \<le> \<parallel>f\<parallel>\<close>. The function norm \<open>\<parallel>g\<parallel>\<close> is defined as the
      smallest \<open>c \<in> \<real>\<close> such that
      \begin{center}
      \begin{tabular}{l}
      \<open>\<forall>x \<in> E. \<bar>g x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>\<close>
      \end{tabular}
      \end{center}
      \<^noindent> Furthermore holds
      \begin{center}
      \begin{tabular}{l}
      \<open>\<forall>x \<in> E. \<bar>g x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>\<close>
      \end{tabular}
      \end{center}
    \<close>

    from g_cont _ ge_zero
    show "\<parallel>g\<parallel>\<hyphen>E \<le> \<parallel>f\<parallel>\<hyphen>F"
    proof
      fix x assume "x \<in> E"
      with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
        by (simp only: p_def)
    qed

    txt \<open>The other direction is achieved by a similar argument.\<close>

    show "\<parallel>f\<parallel>\<hyphen>F \<le> \<parallel>g\<parallel>\<hyphen>E"
    proof (rule normed_vectorspace_with_fn_norm.fn_norm_least
        [OF normed_vectorspace_with_fn_norm.intro,
         OF F_norm, folded B_def fn_norm_def])
      fix x assume x: "x \<in> F"
      show "\<bar>f x\<bar> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
      proof -
        from a x have "g x = f x" ..
        then have "\<bar>f x\<bar> = \<bar>g x\<bar>" by (simp only:)
        also from g_cont have "\<dots> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
        proof (rule fn_norm_le_cong [OF _ linearformE, folded B_def fn_norm_def])
          from FE x show "x \<in> E" ..
        qed
        finally show ?thesis .
      qed
    next
      show "0 \<le> \<parallel>g\<parallel>\<hyphen>E"
        using g_cont by (rule fn_norm_ge_zero [of g, folded B_def fn_norm_def])
      show "continuous F f norm" by fact
    qed
  qed
  with linearformE a g_cont show ?thesis by blast
qed

end


section \<open>Implementation of the Edmonds-Karp Algorithm\<close>
theory EdmondsKarp_Impl
imports
  EdmondsKarp_Algo
  Augmenting_Path_BFS
  Refine_Imperative_HOL.IICF
begin

  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. *)
    definition "find_shortest_augmenting_spec_cf cf \<equiv>
      assert (RGraph c s t cf) \<then>
      SPEC (\<lambda>
        None \<Rightarrow> \<not>Graph.connected cf s t
      | Some p \<Rightarrow> Graph.isShortestPath cf s p t)"

    lemma (in RGraph) find_shortest_augmenting_spec_cf_refine:
       "find_shortest_augmenting_spec_cf cf
      \<le> find_shortest_augmenting_spec (flow_of_cf cf)"
      unfolding f_def[symmetric]
      unfolding find_shortest_augmenting_spec_cf_def
        and find_shortest_augmenting_spec_def
      by (auto
        simp: pw_le_iff refine_pw_simps
        simp: this_loc rg_is_cf
        simp: f.isAugmentingPath_def Graph.connected_def Graph.isSimplePath_def
        dest: cf.shortestPath_is_path
        split: option.split)

    text \<open>This leads to the following refined algorithm\<close>
    definition "edka2 \<equiv> do {
      let cf = c;

      (cf,_) \<leftarrow> while\<^sub>T
        (\<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> return (cf,True)
          | Some p \<Rightarrow> do {
              assert (p\<noteq>[]);
              assert (Graph.isShortestPath cf s p t);
              let cf = Graph.augment_cf cf (set p) (resCap_cf cf p);
              assert (RGraph c s t cf);
              return (cf, False)
            }
        })
        (cf,False);
      assert (RGraph c s t cf);
      let f = flow_of_cf cf;
      return f
    }"

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

      show ?thesis
        unfolding edka2_def edka_def
        (*apply (rewrite in "let f' = NFlow.augmentingFlow c _ _ in _" Let_def)
        apply (rewrite in "let f = flow_of_cf _ in _" Let_def)*)
        apply (refine_rcg)
        apply refine_dref_type
        apply vc_solve

        \<comment> \<open>Solve some left-over verification conditions one by one\<close>
        apply (drule NFlow.is_RGraph;
            auto simp: cfi_rel_def br_def residualGraph_zero_flow flow_of_c;
            fail)
        apply (auto simp: cfi_rel_def br_def; fail)
        using RGraph.find_shortest_augmenting_spec_cf_refine
        apply (auto simp: cfi_rel_def br_def; fail)
        apply (auto simp: cfi_rel_def br_def simp: RPreGraph.rg_fo_inv[OF RGraph.this_loc_rpg]; fail)
        apply (drule (1) augment_cf_refine; simp add: cfi_rel_def br_def; fail)
        apply (simp add: augment_cf_refine; fail)
        apply (auto simp: cfi_rel_def br_def; fail)
        apply (auto simp: cfi_rel_def br_def; fail)
        done

    qed

    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 (input) valid_edge :: "edge \<Rightarrow> bool" where
      "valid_edge \<equiv> \<lambda>(u,v). u\<in>V \<and> v\<in>V"

    definition cf_get
      :: "'capacity graph \<Rightarrow> edge \<Rightarrow> 'capacity nres"
      where "cf_get cf e \<equiv> ASSERT (valid_edge e) \<then> RETURN (cf e)"
    definition cf_set
      :: "'capacity graph \<Rightarrow> edge \<Rightarrow> 'capacity \<Rightarrow> 'capacity graph nres"
      where "cf_set cf e cap \<equiv> ASSERT (valid_edge e) \<then> RETURN (cf(e:=cap))"

    definition resCap_cf_impl :: "'capacity graph \<Rightarrow> path \<Rightarrow> 'capacity nres"
    where "resCap_cf_impl cf p \<equiv>
      case p of
        [] \<Rightarrow> RETURN (0::'capacity)
      | (e#p) \<Rightarrow> do {
          cap \<leftarrow> cf_get cf e;
          ASSERT (distinct p);
          nfoldli
            p (\<lambda>_. True)
            (\<lambda>e cap. do {
              cape \<leftarrow> cf_get cf e;
              RETURN (min cape cap)
            })
            cap
        }"

    lemma (in RGraph) resCap_cf_impl_refine:
      assumes AUG: "cf.isSimplePath s p t"
      shows "resCap_cf_impl cf p \<le> SPEC (\<lambda>r. r = resCap_cf cf 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_def resCap_cf_def cf_get_def
        apply (simp only: list.case)
        apply (refine_vcg nfoldli_rule[where
            I = "\<lambda>l l' cap.
              cap = Min (cf`insert e (set l))
            \<and> set (l@l') \<subseteq> Collect valid_edge"])
        apply (auto intro!: arg_cong[where f=Min])
        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
      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 "augment_edge_impl cf e cap \<equiv> do {
      v \<leftarrow> cf_get cf e; cf \<leftarrow> cf_set cf e (v-cap);
      let e = prod.swap e;
      v \<leftarrow> cf_get cf e; cf \<leftarrow> cf_set cf e (v+cap);
      RETURN cf
    }"

    lemma augment_edge_impl_refine:
      assumes "valid_edge e" "\<forall>u. e\<noteq>(u,u)"
      shows "augment_edge_impl cf e cap
          \<le> (spec r. r = Graph.augment_edge cf e cap)"
      using assms
      unfolding augment_edge_impl_def Graph.augment_edge_def
      unfolding cf_get_def cf_set_def
      apply refine_vcg
      apply auto
      done

    definition augment_cf_impl
      :: "'capacity graph \<Rightarrow> path \<Rightarrow> 'capacity \<Rightarrow> 'capacity graph nres"
      where
      "augment_cf_impl cf p x \<equiv> do {
        (rec\<^sub>T D. \<lambda>
          ([],cf) \<Rightarrow> return cf
        | (e#p,cf) \<Rightarrow> do {
            cf \<leftarrow> augment_edge_impl cf e x;
            D (p,cf)
          }
        ) (p,cf)
      }"

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

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

    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> RETURN (Graph.augment_cf cf (set p) x)"
      using assms
      apply (induction p arbitrary: cf)
      apply (simp add: Graph.augment_cf_empty)

      apply clarsimp
      apply (subst Graph.augment_cf_inductive, assumption)

      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

      (cf,_) \<leftarrow> while\<^sub>T
        (\<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> return (cf,True)
          | Some p \<Rightarrow> do {
              assert (p\<noteq>[]);
              assert (Graph.isShortestPath cf s p t);
              bn \<leftarrow> resCap_cf_impl cf p;
              cf \<leftarrow> augment_cf_impl cf p bn;
              assert (RGraph c s t cf);
              return (cf, False)
            }
        })
        (cf,False);
      assert (RGraph c s t cf);
      let f = flow_of_cf cf;
      return f
    }"

    lemma edka3_refine: "edka3 \<le> \<Down>Id edka2"
      unfolding edka3_def edka2_def
      apply (rewrite in "let cf = Graph.augment_cf _ _ _ in _" Let_def)
      apply refine_rcg
      apply refine_dref_type
      apply (vc_solve)
      apply (drule Graph.shortestPath_is_simple)
      apply (frule (1) RGraph.resCap_cf_impl_refine)
      apply (frule (1) RGraph.augment_cf_impl_refine)
      apply (auto simp: pw_le_iff refine_pw_simps)
      done

    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 {
      let cf = c;

      (cf,_) \<leftarrow> while\<^sub>T
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          assert (RGraph c s t cf);
          p \<leftarrow> Graph.bfs cf s t;
          case p of
            None \<Rightarrow> return (cf,True)
          | Some p \<Rightarrow> do {
              assert (p\<noteq>[]);
              assert (Graph.isShortestPath cf s p t);
              bn \<leftarrow> resCap_cf_impl cf p;
              cf \<leftarrow> augment_cf_impl cf p bn;
              assert (RGraph c s t cf);
              return (cf, False)
            }
        })
        (cf,False);
      assert (RGraph c s t cf);
      let f = flow_of_cf cf;
      return f
    }"

    text \<open>A shortest path can be obtained by BFS\<close>
    lemma bfs_refines_shortest_augmenting_spec:
      "Graph.bfs cf s t \<le> find_shortest_augmenting_spec_cf cf"
      unfolding find_shortest_augmenting_spec_cf_def
      apply (rule le_ASSERTI)
      apply (rule order_trans)
      apply (rule Graph.bfs_correct)
      apply (simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg] s_node)
      apply (simp add: RPreGraph.resV_netV[OF RGraph.this_loc_rpg])
      apply (simp)
      done

    lemma edka4_refine: "edka4 \<le> \<Down>Id edka3"
      unfolding edka4_def edka3_def
      apply refine_rcg
      apply refine_dref_type
      apply (vc_solve simp: bfs_refines_shortest_augmenting_spec)
      done

    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 "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 ps_get_op :: "_ \<Rightarrow> node \<Rightarrow> node list nres"
      where "ps_get_op am u \<equiv> assert (u\<in>V) \<then> return (am u)"

    definition monadic_filter_rev_aux
      :: "'a list \<Rightarrow> ('a \<Rightarrow> bool nres) \<Rightarrow> 'a list \<Rightarrow> 'a list nres"
    where
      "monadic_filter_rev_aux a P l \<equiv> (rec\<^sub>T D. (\<lambda>(l,a). case l of
        [] \<Rightarrow> return a
      | (v#l) \<Rightarrow> do {
          c \<leftarrow> P v;
          let a = (if c then v#a else a);
          D (l,a)
        }
      )) (l,a)"

    lemma monadic_filter_rev_aux_rule:
      assumes "\<And>x. x\<in>set l \<Longrightarrow> P x \<le> SPEC (\<lambda>r. r=Q x)"
      shows "monadic_filter_rev_aux a P l \<le> SPEC (\<lambda>r. r=filter_rev_aux a Q l)"
      using assms
      apply (induction l arbitrary: a)

      apply (unfold monadic_filter_rev_aux_def) []
      apply (subst RECT_unfold, refine_mono)
      apply (fold monadic_filter_rev_aux_def) []
      apply simp

      apply (unfold monadic_filter_rev_aux_def) []
      apply (subst RECT_unfold, refine_mono)
      apply (fold monadic_filter_rev_aux_def) []
      apply (auto simp: pw_le_iff refine_pw_simps)
      done

    definition "monadic_filter_rev = monadic_filter_rev_aux []"

    lemma monadic_filter_rev_rule:
      assumes "\<And>x. x\<in>set l \<Longrightarrow> P x \<le> (spec r. r=Q x)"
      shows "monadic_filter_rev P l \<le> (spec r. r=filter_rev Q l)"
      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> cf_get cf (u,v);
        return (x>0)
      }) l
    }"

    lemma (in RGraph) rg_succ_ref2:
      assumes PS: "is_adj_map am" and V: "u\<in>V"
      shows "rg_succ2 am cf u \<le> return (rg_succ am cf u)"
    proof -
      have "\<forall>v\<in>set (am u). valid_edge (u,v)"
        using PS V
        by (auto simp: is_adj_map_def Graph.V_def)

      thus ?thesis
        unfolding rg_succ2_def rg_succ_def ps_get_op_def cf_get_def
        apply (refine_vcg monadic_filter_rev_rule[
            where Q="(\<lambda>v. 0 < cf (u, v))", THEN order_trans])
        by (vc_solve simp: V)
    qed

    lemma (in RGraph) rg_succ_ref:
      assumes A: "is_adj_map am"
      assumes B: "u\<in>V"
      shows "rg_succ2 am cf u \<le> SPEC (\<lambda>l. (l,cf.E``{u}) \<in> \<langle>Id\<rangle>list_set_rel)"
      using rg_succ_ref1[OF A, of u] rg_succ_ref2[OF A B]
      by (auto simp: pw_le_iff refine_pw_simps)

    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 init_cf :: "'capacity graph nres"
      \<comment> \<open>Initialization of residual graph from network\<close>
      where "init_cf \<equiv> RETURN c"
    definition init_ps :: "(node \<Rightarrow> node list) \<Rightarrow> _"
      \<comment> \<open>Initialization of adjacency map\<close>
      where "init_ps am \<equiv> ASSERT (is_adj_map am) \<then> RETURN am"

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

    definition "bfs2_op am cf \<equiv> Graph.bfs2 cf (rg_succ2 am cf) s t"

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

    definition "edka5_run cf am \<equiv> do {
      (cf,_) \<leftarrow> while\<^sub>T
        (\<lambda>(cf,brk). \<not>brk)
        (\<lambda>(cf,_). do {
          assert (RGraph c s t cf);
          p \<leftarrow> bfs2_op am cf;
          case p of
            None \<Rightarrow> return (cf,True)
          | Some p \<Rightarrow> do {
              assert (p\<noteq>[]);
              assert (Graph.isShortestPath cf s p t);
              bn \<leftarrow> resCap_cf_impl cf p;
              cf \<leftarrow> augment_cf_impl cf p bn;
              assert (RGraph c s t cf);
              return (cf, False)
            }
        })
        (cf,False);
      f \<leftarrow> compute_rflow cf;
      return f
    }"

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

    lemma edka5_refine: "\<lbrakk>is_adj_map am\<rbrakk> \<Longrightarrow> edka5 am \<le> \<Down>Id edka4"
      unfolding edka5_def edka5_tabulate_def edka5_run_def
        edka4_def init_cf_def compute_rflow_def
        init_ps_def Let_def nres_monad_laws bfs2_op_def
      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

  end

  subsection \<open>Imperative Implementation\<close>
  text \<open>In this section we provide an efficient imperative implementation,
    using the Sepref tool. It is mostly technical, setting up the mappings
    from abstract to concrete data structures, and then refining the algorithm,
    function by function.
    \<close>

  text \<open>
    This is also the point where we have to choose the implementation of
    capacities. Up to here, they have been a polymorphic type with a
    typeclass constraint of being a linearly ordered integral domain.
    Here, we switch to @{typ [source] capacity_impl} (@{typ capacity_impl}).
    \<close>
  locale Network_Impl = Network c s t for c :: "capacity_impl graph" and s t

  text \<open>Moreover, we assume that the nodes are natural numbers less
    than some number @{term N}, which will become an additional parameter
    of our algorithm. \<close>
  locale Edka_Impl = Network_Impl +
    fixes N :: nat
    assumes V_ss: "V\<subseteq>{0..<N}"
  begin
    lemma this_loc: "Edka_Impl c s t N" by unfold_locales

    lemma E_ss: "E \<subseteq> {0..<N}\<times>{0..<N}" using E_ss_VxV V_ss by auto

    lemma mtx_nonzero_iff[simp]: "mtx_nonzero c = E" unfolding E_def by (auto simp: mtx_nonzero_def)

    lemma mtx_nonzeroN: "mtx_nonzero c \<subseteq> {0..<N}\<times>{0..<N}" using E_ss by simp

    text \<open>Declare some variables to Sepref. \<close>
    lemmas [id_rules] =
      itypeI[Pure.of N "TYPE(nat)"]
      itypeI[Pure.of s "TYPE(node)"]
      itypeI[Pure.of t "TYPE(node)"]
      itypeI[Pure.of c "TYPE(capacity_impl graph)"]
    text \<open>Instruct Sepref to not refine these parameters. This is expressed
      by using identity as refinement relation.\<close>
    lemmas [sepref_import_param] =
      IdI[of N]
      IdI[of s]
      IdI[of t]
      (*IdI[of c]*)

    lemma [sepref_fr_rules]: "(uncurry0 (return c),uncurry0 (return c))\<in>unit_assn\<^sup>k \<rightarrow>\<^sub>a pure (nat_rel\<times>\<^sub>rnat_rel \<rightarrow> int_rel)"
      apply sepref_to_hoare by sep_auto

    subsubsection \<open>Implementation of Adjacency Map by Array\<close>
    definition "is_am am psi
      \<equiv> \<exists>\<^sub>Al. psi \<mapsto>\<^sub>a l
          * \<up>(length l = N \<and> (\<forall>i<N. l!i = am i)
              \<and> (\<forall>i\<ge>N. am i = []))"

    lemma is_am_precise[safe_constraint_rules]: "precise (is_am)"
      apply rule
      unfolding is_am_def
      apply clarsimp
      apply (rename_tac l l')
      apply prec_extract_eqs
      apply (rule ext)
      apply (rename_tac i)
      apply (case_tac "i<length l'")
      apply fastforce+
      done

    sepref_decl_intf i_ps is "nat \<Rightarrow> nat list"

    definition (in -) "ps_get_imp psi u \<equiv> Array.nth psi u"

    lemma ps_get_op_refine[sepref_fr_rules]:
      "(uncurry ps_get_imp, uncurry (PR_CONST ps_get_op))
        \<in> is_am\<^sup>k *\<^sub>a (pure Id)\<^sup>k \<rightarrow>\<^sub>a list_assn (pure Id)"
      unfolding list_assn_pure_conv
      apply sepref_to_hoare
      using V_ss
      by (sep_auto
            simp: is_am_def pure_def ps_get_imp_def
            simp: ps_get_op_def refine_pw_simps)

    lemma is_pred_succ_no_node: "\<lbrakk>is_adj_map a; u\<notin>V\<rbrakk> \<Longrightarrow> a u = []"
      unfolding is_adj_map_def V_def
      by auto

    lemma [sepref_fr_rules]: "(Array.make N, PR_CONST init_ps)
      \<in> (pure Id)\<^sup>k \<rightarrow>\<^sub>a is_am"
      apply sepref_to_hoare
      using V_ss
      by (sep_auto simp: init_ps_def refine_pw_simps is_am_def pure_def
        intro: is_pred_succ_no_node)

    lemma [def_pat_rules]: "Network.init_ps$c \<equiv> UNPROTECT init_ps" by simp
    sepref_register "PR_CONST init_ps" :: "(node \<Rightarrow> node list) \<Rightarrow> i_ps nres"

    subsubsection \<open>Implementation of Capacity Matrix by Array\<close>
    lemma [def_pat_rules]: "Network.cf_get$c \<equiv> UNPROTECT cf_get" by simp
    lemma [def_pat_rules]: "Network.cf_set$c \<equiv> UNPROTECT cf_set" by simp

    sepref_register
      "PR_CONST cf_get" :: "capacity_impl i_mtx \<Rightarrow> edge \<Rightarrow> capacity_impl nres"
    sepref_register
      "PR_CONST cf_set" :: "capacity_impl i_mtx \<Rightarrow> edge \<Rightarrow> capacity_impl
        \<Rightarrow> capacity_impl i_mtx nres"

    text \<open>We have to link the matrix implementation, which encodes the bound,
      to the abstract assertion of the bound\<close>

    sepref_definition cf_get_impl is "uncurry (PR_CONST cf_get)" :: "(asmtx_assn N id_assn)\<^sup>k *\<^sub>a (prod_assn id_assn id_assn)\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding PR_CONST_def cf_get_def[abs_def]
      by sepref
    lemmas [sepref_fr_rules] = cf_get_impl.refine
    lemmas [sepref_opt_simps] = cf_get_impl_def

    sepref_definition cf_set_impl is "uncurry2 (PR_CONST cf_set)" :: "(asmtx_assn N id_assn)\<^sup>d *\<^sub>a (prod_assn id_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a asmtx_assn N id_assn"
      unfolding PR_CONST_def cf_set_def[abs_def]
      by sepref
    lemmas [sepref_fr_rules] = cf_set_impl.refine
    lemmas [sepref_opt_simps] = cf_set_impl_def

    sepref_thm init_cf_impl is "uncurry0 (PR_CONST init_cf)" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a asmtx_assn N id_assn"
      unfolding PR_CONST_def init_cf_def
      using E_ss
      apply (rewrite op_mtx_new_def[of c, symmetric])
      apply (rewrite amtx_fold_custom_new[of N N])
      by sepref

    concrete_definition (in -) init_cf_impl uses Edka_Impl.init_cf_impl.refine_raw is "(uncurry0 ?f,_)\<in>_"
    prepare_code_thms (in -) init_cf_impl_def
    lemmas [sepref_fr_rules] = init_cf_impl.refine[OF this_loc]

    (* TODO: Use sepref to synthesize the get-operations! *)
    lemma amtx_cnv: "amtx_assn N M id_assn = IICF_Array_Matrix.is_amtx N M"
      by (simp add: amtx_assn_def)

    (*

    lemma init_cf_imp_refine[sepref_fr_rules]:
      "(uncurry0 (mtx_new N c), uncurry0 (PR_CONST init_cf))
        \<in> (pure unit_rel)\<^sup>k \<rightarrow>\<^sub>a (asmtx_assn N id_assn)"
      unfolding asmtx_cnv
      apply sepref_to_hoare
      using E_ss
      by (sep_auto simp: init_cf_def)
    *)

    lemma [def_pat_rules]: "Network.init_cf$c \<equiv> UNPROTECT init_cf" by simp
    sepref_register "PR_CONST init_cf" :: "capacity_impl i_mtx nres"

    subsubsection \<open>Representing Result Flow as Residual Graph\<close>
    definition (in Network_Impl) "is_rflow N f cfi
      \<equiv> \<exists>\<^sub>Acf. asmtx_assn N id_assn cf cfi * \<up>(RGraph c s t cf \<and> f = flow_of_cf cf)"
    lemma is_rflow_precise[safe_constraint_rules]: "precise (is_rflow N)"
      apply rule
      unfolding is_rflow_def
      apply (clarsimp simp: amtx_assn_def)
      apply prec_extract_eqs
      apply simp
      done

    sepref_decl_intf i_rflow is "nat\<times>nat \<Rightarrow> int"

    lemma [sepref_fr_rules]:
      "(\<lambda>cfi. return cfi, PR_CONST compute_rflow) \<in> (asmtx_assn N id_assn)\<^sup>d \<rightarrow>\<^sub>a is_rflow N"
      unfolding amtx_cnv
      apply sepref_to_hoare
      apply (sep_auto simp: amtx_cnv compute_rflow_def is_rflow_def refine_pw_simps hn_ctxt_def)
      done

    lemma [def_pat_rules]:
      "Network.compute_rflow$c$s$t \<equiv> UNPROTECT compute_rflow" by simp
    sepref_register
      "PR_CONST compute_rflow" :: "capacity_impl i_mtx \<Rightarrow> i_rflow nres"

    subsubsection \<open>Implementation of Functions\<close>

    schematic_goal rg_succ2_impl:
      fixes am :: "node \<Rightarrow> node list" and cf :: "capacity_impl graph"
      notes [id_rules] =
        itypeI[Pure.of u "TYPE(node)"]
        itypeI[Pure.of am "TYPE(i_ps)"]
        itypeI[Pure.of cf "TYPE(capacity_impl i_mtx)"]
      notes [sepref_import_param] = IdI[of N]
      notes [sepref_fr_rules] = HOL_list_empty_hnr
      shows "hn_refine (hn_ctxt is_am am psi * hn_ctxt (asmtx_assn N id_assn) cf cfi * hn_val nat_rel u ui) (?c::?'c Heap) ?\<Gamma> ?R (rg_succ2 am cf u)"
      unfolding rg_succ2_def APP_def monadic_filter_rev_def monadic_filter_rev_aux_def
      (* TODO: Make setting up combinators for sepref simpler, then we do not need to unfold! *)
      using [[id_debug, goals_limit = 1]]
      by sepref
    concrete_definition (in -) succ_imp uses Edka_Impl.rg_succ2_impl
    prepare_code_thms (in -) succ_imp_def

    lemma succ_imp_refine[sepref_fr_rules]:
      "(uncurry2 (succ_imp N), uncurry2 (PR_CONST rg_succ2))
        \<in> is_am\<^sup>k *\<^sub>a (asmtx_assn N id_assn)\<^sup>k *\<^sub>a (pure Id)\<^sup>k \<rightarrow>\<^sub>a list_assn (pure Id)"
      apply rule
      using succ_imp.refine[OF this_loc]
      by (auto simp: hn_ctxt_def mult_ac split: prod.split)

    lemma [def_pat_rules]: "Network.rg_succ2$c \<equiv> UNPROTECT rg_succ2" by simp
    sepref_register
      "PR_CONST rg_succ2" :: "i_ps \<Rightarrow> capacity_impl i_mtx \<Rightarrow> node \<Rightarrow> node list nres"

    lemma [sepref_import_param]: "(min,min)\<in>Id\<rightarrow>Id\<rightarrow>Id" by simp

    abbreviation "is_path \<equiv> list_assn (prod_assn (pure Id) (pure Id))"

    schematic_goal resCap_imp_impl:
      fixes am :: "node \<Rightarrow> node list" and cf :: "capacity_impl graph" and p pi
      notes [id_rules] =
        itypeI[Pure.of p "TYPE(edge list)"]
        itypeI[Pure.of cf "TYPE(capacity_impl i_mtx)"]
      notes [sepref_import_param] = IdI[of N]
      shows "hn_refine
        (hn_ctxt (asmtx_assn N id_assn) cf cfi * hn_ctxt is_path p pi)
        (?c::?'c Heap) ?\<Gamma> ?R
        (resCap_cf_impl cf p)"
      unfolding resCap_cf_impl_def APP_def
      using [[id_debug, goals_limit = 1]]
      by sepref
    concrete_definition (in -) resCap_imp uses Edka_Impl.resCap_imp_impl
    prepare_code_thms (in -) resCap_imp_def

    lemma resCap_impl_refine[sepref_fr_rules]:
      "(uncurry (resCap_imp N), uncurry (PR_CONST resCap_cf_impl))
        \<in> (asmtx_assn N id_assn)\<^sup>k *\<^sub>a (is_path)\<^sup>k \<rightarrow>\<^sub>a (pure Id)"
      apply sepref_to_hnr
      apply (rule hn_refine_preI)
      apply (clarsimp
        simp: uncurry_def list_assn_pure_conv hn_ctxt_def
        split: prod.split)
      apply (clarsimp simp: pure_def)
      apply (rule hn_refine_cons[OF _ resCap_imp.refine[OF this_loc] _])
      apply (simp add: list_assn_pure_conv hn_ctxt_def)
      apply (simp add: pure_def)
      apply (sep_auto simp add: hn_ctxt_def pure_def intro!: enttI)
      apply (simp add: pure_def)
      done

    lemma [def_pat_rules]:
      "Network.resCap_cf_impl$c \<equiv> UNPROTECT resCap_cf_impl"
      by simp
    sepref_register "PR_CONST resCap_cf_impl"
      :: "capacity_impl i_mtx \<Rightarrow> path \<Rightarrow> capacity_impl nres"

    sepref_thm augment_imp is "uncurry2 (PR_CONST augment_cf_impl)" :: "((asmtx_assn N id_assn)\<^sup>d *\<^sub>a (is_path)\<^sup>k *\<^sub>a (pure Id)\<^sup>k \<rightarrow>\<^sub>a asmtx_assn N id_assn)"
      unfolding augment_cf_impl_def[abs_def] augment_edge_impl_def PR_CONST_def
      using [[id_debug, goals_limit = 1]]
      by sepref
    concrete_definition (in -) augment_imp uses Edka_Impl.augment_imp.refine_raw is "(uncurry2 ?f,_)\<in>_"
    prepare_code_thms (in -) augment_imp_def
    lemma augment_impl_refine[sepref_fr_rules]:
      "(uncurry2 (augment_imp N), uncurry2 (PR_CONST augment_cf_impl))
        \<in> (asmtx_assn N id_assn)\<^sup>d *\<^sub>a (is_path)\<^sup>k *\<^sub>a (pure Id)\<^sup>k \<rightarrow>\<^sub>a asmtx_assn N id_assn"
      using augment_imp.refine[OF this_loc] .

    lemma [def_pat_rules]:
      "Network.augment_cf_impl$c \<equiv> UNPROTECT augment_cf_impl"
      by simp
    sepref_register "PR_CONST augment_cf_impl"
      :: "capacity_impl i_mtx \<Rightarrow> path \<Rightarrow> capacity_impl \<Rightarrow> capacity_impl i_mtx nres"

    sublocale bfs: Impl_Succ
      "snd"
      "TYPE(i_ps \<times> capacity_impl i_mtx)"
      "PR_CONST (\<lambda>(am,cf). rg_succ2 am cf)"
      "prod_assn is_am (asmtx_assn N id_assn)"
      "\<lambda>(am,cf). succ_imp N am cf"
      unfolding APP_def
      apply unfold_locales
      apply (simp add: fold_partial_uncurry)
      apply (rule hfref_cons[OF succ_imp_refine[unfolded PR_CONST_def]])
      by auto

    definition (in -) "bfsi' N s t psi cfi
      \<equiv> bfs_impl (\<lambda>(am, cf). succ_imp N am cf) (psi,cfi) s t"

    lemma [sepref_fr_rules]:
      "(uncurry (bfsi' N s t),uncurry (PR_CONST bfs2_op))
        \<in> is_am\<^sup>k *\<^sub>a (asmtx_assn N id_assn)\<^sup>k \<rightarrow>\<^sub>a option_assn is_path"
      unfolding bfsi'_def[abs_def] bfs2_op_def[abs_def]
      using bfs.bfs_impl_fr_rule unfolding bfs.op_bfs_def[abs_def]
      apply (clarsimp simp: hfref_def all_to_meta)
      apply (rule hn_refine_cons[rotated])
      apply rprems
      apply (sep_auto simp: pure_def intro!: enttI)
      apply (sep_auto simp: pure_def)
      apply (sep_auto simp: pure_def)
      done

    lemma [def_pat_rules]: "Network.bfs2_op$c$s$t \<equiv> UNPROTECT bfs2_op" by simp
    sepref_register "PR_CONST bfs2_op"
      :: "i_ps \<Rightarrow> capacity_impl i_mtx \<Rightarrow> path option nres"

    schematic_goal edka_imp_tabulate_impl:
      notes [sepref_opt_simps] = heap_WHILET_def
      fixes am :: "node \<Rightarrow> node list" and cf :: "capacity_impl graph"
      notes [id_rules] =
        itypeI[Pure.of am "TYPE(node \<Rightarrow> node list)"]
      notes [sepref_import_param] = IdI[of am]
      shows "hn_refine (emp) (?c::?'c Heap) ?\<Gamma> ?R (edka5_tabulate am)"
      unfolding edka5_tabulate_def
      using [[id_debug, goals_limit = 1]]
      by sepref

    concrete_definition (in -) edka_imp_tabulate
      uses Edka_Impl.edka_imp_tabulate_impl
    prepare_code_thms (in -) edka_imp_tabulate_def

    lemma edka_imp_tabulate_refine[sepref_fr_rules]:
      "(edka_imp_tabulate c N, PR_CONST edka5_tabulate)
      \<in> (pure Id)\<^sup>k \<rightarrow>\<^sub>a prod_assn (asmtx_assn N id_assn) is_am"
      apply (rule)
      apply (rule hn_refine_preI)
      apply (clarsimp
        simp: uncurry_def list_assn_pure_conv hn_ctxt_def
        split: prod.split)
      apply (rule hn_refine_cons[OF _ edka_imp_tabulate.refine[OF this_loc]])
      apply (sep_auto simp: hn_ctxt_def pure_def)+
      done

    lemma [def_pat_rules]:
      "Network.edka5_tabulate$c \<equiv> UNPROTECT edka5_tabulate"
      by simp
    sepref_register "PR_CONST edka5_tabulate"
      :: "(node \<Rightarrow> node list) \<Rightarrow> (capacity_impl i_mtx \<times> i_ps) nres"

    schematic_goal edka_imp_run_impl:
      notes [sepref_opt_simps] = heap_WHILET_def
      fixes am :: "node \<Rightarrow> node list" and cf :: "capacity_impl graph"
      notes [id_rules] =
        itypeI[Pure.of cf "TYPE(capacity_impl i_mtx)"]
        itypeI[Pure.of am "TYPE(i_ps)"]
      shows "hn_refine
        (hn_ctxt (asmtx_assn N id_assn) cf cfi * hn_ctxt is_am am psi)
        (?c::?'c Heap) ?\<Gamma> ?R
        (edka5_run cf am)"
      unfolding edka5_run_def
      using [[id_debug, goals_limit = 1]]
      by sepref

    concrete_definition (in -) edka_imp_run uses Edka_Impl.edka_imp_run_impl
    prepare_code_thms (in -) edka_imp_run_def

    thm edka_imp_run_def
    lemma edka_imp_run_refine[sepref_fr_rules]:
      "(uncurry (edka_imp_run s t N), uncurry (PR_CONST edka5_run))
        \<in> (asmtx_assn N id_assn)\<^sup>d *\<^sub>a (is_am)\<^sup>k \<rightarrow>\<^sub>a is_rflow N"
      apply rule
      apply (clarsimp
        simp: uncurry_def list_assn_pure_conv hn_ctxt_def
        split: prod.split)
      apply (rule hn_refine_cons[OF _ edka_imp_run.refine[OF this_loc] _])
      apply (sep_auto simp: hn_ctxt_def)+
      done

    lemma [def_pat_rules]:
      "Network.edka5_run$c$s$t \<equiv> UNPROTECT edka5_run"
      by simp
    sepref_register "PR_CONST edka5_run"
      :: "capacity_impl i_mtx \<Rightarrow> i_ps \<Rightarrow> i_rflow nres"

    schematic_goal edka_imp_impl:
      notes [sepref_opt_simps] = heap_WHILET_def
      fixes am :: "node \<Rightarrow> node list" and cf :: "capacity_impl graph"
      notes [id_rules] =
        itypeI[Pure.of am "TYPE(node \<Rightarrow> node list)"]
      notes [sepref_import_param] = IdI[of am]
      shows "hn_refine (emp) (?c::?'c Heap) ?\<Gamma> ?R (edka5 am)"
      unfolding edka5_def
      using [[id_debug, goals_limit = 1]]
      by sepref

    concrete_definition (in -) edka_imp uses Edka_Impl.edka_imp_impl
    prepare_code_thms (in -) edka_imp_def
    lemmas edka_imp_refine = edka_imp.refine[OF this_loc]

    thm pat_rules TrueI def_pat_rules

  end

  export_code edka_imp checking SML_imp

  subsection \<open>Correctness Theorem for Implementation\<close>
  text \<open>We combine all refinement steps to derive a correctness
    theorem for the implementation\<close>
  context Network_Impl begin
    theorem edka_imp_correct:
      assumes VN: "Graph.V c \<subseteq> {0..<N}"
      assumes ABS_PS: "is_adj_map am"
      shows "
        <emp>
          edka_imp c s t N am
        <\<lambda>fi. \<exists>\<^sub>Af. is_rflow N f fi * \<up>(isMaxFlow f)>\<^sub>t"
    proof -
      interpret Edka_Impl by unfold_locales fact

      note edka5_refine[OF ABS_PS]
      also note edka4_refine
      also note edka3_refine
      also note edka2_refine
      also note edka_refine
      also note edka_partial_refine
      also note fofu_partial_correct
      finally have "edka5 am \<le> SPEC isMaxFlow" .
      from hn_refine_ref[OF this edka_imp_refine]
      show ?thesis
        by (simp add: hn_refine_def)
    qed
  end
end