(*  Title:      HOL/ex/Reflection_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Examples for generic reflection and reification\<close>

theory Reflection_Examples
imports Complex_Main "HOL-Library.Reflection"
begin

text \<open>This theory presents two methods: reify and reflection\<close>

text \<open>
Consider an HOL type \<open>\<sigma>\<close>, the structure of which is not recongnisable
on the theory level.  This is the case of @{typ bool}, arithmetical terms such as @{typ int},
@{typ real} etc \dots  In order to implement a simplification on terms of type \<open>\<sigma>\<close> we
often need its structure.  Traditionnaly such simplifications are written in ML,
proofs are synthesized.

An other strategy is to declare an HOL datatype \<open>\<tau>\<close> and an HOL function (the
interpretation) that maps elements of \<open>\<tau>\<close> to elements of \<open>\<sigma>\<close>.

The functionality of \<open>reify\<close> then is, given a term \<open>t\<close> of type \<open>\<sigma>\<close>,
to compute a term \<open>s\<close> of type \<open>\<tau>\<close>.  For this it needs equations for the
interpretation.

N.B: All the interpretations supported by \<open>reify\<close> must have the type
\<open>'a list \<Rightarrow> \<tau> \<Rightarrow> \<sigma>\<close>.  The method \<open>reify\<close> can also be told which subterm
of the current subgoal should be reified.  The general call for \<open>reify\<close> is
\<open>reify eqs (t)\<close>, where \<open>eqs\<close> are the defining equations of the interpretation
and \<open>(t)\<close> is an optional parameter which specifies the subterm to which reification
should be applied to.  If \<open>(t)\<close> is abscent, \<open>reify\<close> tries to reify the whole
subgoal.

The method \<open>reflection\<close> uses \<open>reify\<close> and has a very similar signature:
\<open>reflection corr_thm eqs (t)\<close>.  Here again \<open>eqs\<close> and \<open>(t)\<close>
are as described above and \<open>corr_thm\<close> is a theorem proving
@{prop "I vs (f t) = I vs t"}.  We assume that \<open>I\<close> is the interpretation
and \<open>f\<close> is some useful and executable simplification of type \<open>\<tau> \<Rightarrow> \<tau>\<close>.
The method \<open>reflection\<close> applies reification and hence the theorem @{prop "t = I xs s"}
and hence using \<open>corr_thm\<close> derives @{prop "t = I xs (f s)"}.  It then uses
normalization by equational rewriting to prove @{prop "f s = s'"} which almost finishes
the proof of @{prop "t = t'"} where @{prop "I xs s' = t'"}.
\<close>

text \<open>Example 1 : Propositional formulae and NNF.\<close>
text \<open>The type \<open>fm\<close> represents simple propositional formulae:\<close>

datatype form = TrueF | FalseF | Less nat nat
  | And form form | Or form form | Neg form | ExQ form

primrec interp :: "form \<Rightarrow> ('a::ord) list \<Rightarrow> bool"
where
  "interp TrueF vs \<longleftrightarrow> True"
| "interp FalseF vs \<longleftrightarrow> False"
| "interp (Less i j) vs \<longleftrightarrow> vs ! i < vs ! j"
| "interp (And f1 f2) vs \<longleftrightarrow> interp f1 vs \<and> interp f2 vs"
| "interp (Or f1 f2) vs \<longleftrightarrow> interp f1 vs \<or> interp f2 vs"
| "interp (Neg f) vs \<longleftrightarrow> \<not> interp f vs"
| "interp (ExQ f) vs \<longleftrightarrow> (\<exists>v. interp f (v # vs))"

lemmas interp_reify_eqs = interp.simps
declare interp_reify_eqs [reify]

lemma "\<exists>x. x < y \<and> x < z"
  apply reify
  oops

datatype fm = And fm fm | Or fm fm | Imp fm fm | Iff fm fm | NOT fm | At nat

primrec Ifm :: "fm \<Rightarrow> bool list \<Rightarrow> bool"
where
  "Ifm (At n) vs \<longleftrightarrow> vs ! n"
| "Ifm (And p q) vs \<longleftrightarrow> Ifm p vs \<and> Ifm q vs"
| "Ifm (Or p q) vs \<longleftrightarrow> Ifm p vs \<or> Ifm q vs"
| "Ifm (Imp p q) vs \<longleftrightarrow> Ifm p vs \<longrightarrow> Ifm q vs"
| "Ifm (Iff p q) vs \<longleftrightarrow> Ifm p vs = Ifm q vs"
| "Ifm (NOT p) vs \<longleftrightarrow> \<not> Ifm p vs"

lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps)
oops

text \<open>Method \<open>reify\<close> maps a @{typ bool} to an @{typ fm}.  For this it needs the
semantics of \<open>fm\<close>, i.e.\ the rewrite rules in \<open>Ifm.simps\<close>.\<close>

text \<open>You can also just pick up a subterm to reify.\<close>
lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps ("((\<not> D) \<and> (\<not> F))"))
oops

text \<open>Let's perform NNF. This is a version that tends to generate disjunctions\<close>
primrec fmsize :: "fm \<Rightarrow> nat"
where
  "fmsize (At n) = 1"
| "fmsize (NOT p) = 1 + fmsize p"
| "fmsize (And p q) = 1 + fmsize p + fmsize q"
| "fmsize (Or p q) = 1 + fmsize p + fmsize q"
| "fmsize (Imp p q) = 2 + fmsize p + fmsize q"
| "fmsize (Iff p q) = 2 + 2* fmsize p + 2* fmsize q"

lemma [measure_function]: "is_measure fmsize" ..

fun nnf :: "fm \<Rightarrow> fm"
where
  "nnf (At n) = At n"
| "nnf (And p q) = And (nnf p) (nnf q)"
| "nnf (Or p q) = Or (nnf p) (nnf q)"
| "nnf (Imp p q) = Or (nnf (NOT p)) (nnf q)"
| "nnf (Iff p q) = Or (And (nnf p) (nnf q)) (And (nnf (NOT p)) (nnf (NOT q)))"
| "nnf (NOT (And p q)) = Or (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Or p q)) = And (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Imp p q)) = And (nnf p) (nnf (NOT q))"
| "nnf (NOT (Iff p q)) = Or (And (nnf p) (nnf (NOT q))) (And (nnf (NOT p)) (nnf q))"
| "nnf (NOT (NOT p)) = nnf p"
| "nnf (NOT p) = NOT p"

text \<open>The correctness theorem of @{const nnf}: it preserves the semantics of @{typ fm}\<close>
lemma nnf [reflection]:
  "Ifm (nnf p) vs = Ifm p vs"
  by (induct p rule: nnf.induct) auto

text \<open>Now let's perform NNF using our @{const nnf} function defined above.  First to the
  whole subgoal.\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps)
oops

text \<open>Now we specify on which subterm it should be applied\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps only: "B \<or> C \<and> (B \<longrightarrow> A \<or> D)")
oops

text \<open>Example 2: Simple arithmetic formulae\<close>

text \<open>The type \<open>num\<close> reflects linear expressions over natural number\<close>
datatype num = C nat | Add num num | Mul nat num | Var nat | CN nat nat num

text \<open>This is just technical to make recursive definitions easier.\<close>
primrec num_size :: "num \<Rightarrow> nat"
where
  "num_size (C c) = 1"
| "num_size (Var n) = 1"
| "num_size (Add a b) = 1 + num_size a + num_size b"
| "num_size (Mul c a) = 1 + num_size a"
| "num_size (CN n c a) = 4 + num_size a "

lemma [measure_function]: "is_measure num_size" ..

text \<open>The semantics of num\<close>
primrec Inum:: "num \<Rightarrow> nat list \<Rightarrow> nat"
where
  Inum_C  : "Inum (C i) vs = i"
| Inum_Var: "Inum (Var n) vs = vs!n"
| Inum_Add: "Inum (Add s t) vs = Inum s vs + Inum t vs "
| Inum_Mul: "Inum (Mul c t) vs = c * Inum t vs "
| Inum_CN : "Inum (CN n c t) vs = c*(vs!n) + Inum t vs "

text \<open>Let's reify some nat expressions \dots\<close>
lemma "4 * (2 * x + (y::nat)) + f a \<noteq> 0"
  apply (reify Inum.simps ("4 * (2 * x + (y::nat)) + f a"))
oops
text \<open>We're in a bad situation! \<open>x\<close>, \<open>y\<close> and \<open>f\<close> have been recongnized
as constants, which is correct but does not correspond to our intuition of the constructor C.
It should encapsulate constants, i.e. numbers, i.e. numerals.\<close>

text \<open>So let's leave the \<open>Inum_C\<close> equation at the end and see what happens \dots\<close>
lemma "4 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_Var Inum_Add Inum_Mul Inum_CN Inum_C ("4 * (2 * x + (y::nat))"))
oops
text \<open>Hm, let's specialize \<open>Inum_C\<close> with numerals.\<close>

lemma Inum_number: "Inum (C (numeral t)) vs = numeral t" by simp
lemmas Inum_eqs = Inum_Var Inum_Add Inum_Mul Inum_CN Inum_number

text \<open>Second attempt\<close>
lemma "1 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat))"))
oops

text\<open>That was fine, so let's try another one \dots\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Oh!! 0 is not a variable \dots\ Oh! 0 is not a \<open>numeral\<close> \dots\ thing.
The same for 1. So let's add those equations, too.\<close>

lemma Inum_01: "Inum (C 0) vs = 0" "Inum (C 1) vs = 1" "Inum (C(Suc n)) vs = Suc n"
  by simp_all

lemmas Inum_eqs'= Inum_eqs Inum_01

text\<open>Third attempt:\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs' ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Okay, let's try reflection. Some simplifications on @{typ num} follow. You can
  skim until the main theorem \<open>linum\<close>.\<close>

fun lin_add :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "lin_add (CN n1 c1 r1) (CN n2 c2 r2) =
    (if n1 = n2 then
      (let c = c1 + c2
       in (if c = 0 then lin_add r1 r2 else CN n1 c (lin_add r1 r2)))
     else if n1 \<le> n2 then (CN n1 c1 (lin_add r1 (CN n2 c2 r2)))
     else (CN n2 c2 (lin_add (CN n1 c1 r1) r2)))"
| "lin_add (CN n1 c1 r1) t = CN n1 c1 (lin_add r1 t)"
| "lin_add t (CN n2 c2 r2) = CN n2 c2 (lin_add t r2)"
| "lin_add (C b1) (C b2) = C (b1 + b2)"
| "lin_add a b = Add a b"

lemma lin_add:
  "Inum (lin_add t s) bs = Inum (Add t s) bs"
  apply (induct t s rule: lin_add.induct, simp_all add: Let_def)
  apply (case_tac "c1+c2 = 0",case_tac "n1 \<le> n2", simp_all)
  apply (case_tac "n1 = n2", simp_all add: algebra_simps)
  done

fun lin_mul :: "num \<Rightarrow> nat \<Rightarrow> num"
where
  "lin_mul (C j) i = C (i * j)"
| "lin_mul (CN n c a) i = (if i=0 then (C 0) else CN n (i * c) (lin_mul a i))"
| "lin_mul t i = (Mul i t)"

lemma lin_mul:
  "Inum (lin_mul t i) bs = Inum (Mul i t) bs"
  by (induct t i rule: lin_mul.induct) (auto simp add: algebra_simps)

fun linum:: "num \<Rightarrow> num"
where
  "linum (C b) = C b"
| "linum (Var n) = CN n 1 (C 0)"
| "linum (Add t s) = lin_add (linum t) (linum s)"
| "linum (Mul c t) = lin_mul (linum t) c"
| "linum (CN n c t) = lin_add (linum (Mul c (Var n))) (linum t)"

lemma linum [reflection]:
  "Inum (linum t) bs = Inum t bs"
  by (induct t rule: linum.induct) (simp_all add: lin_mul lin_add)

text \<open>Now we can use linum to simplify nat terms using reflection\<close>

lemma "Suc (Suc 1) * (x + Suc 1 * y) = 3 * x + 6 * y"
  apply (reflection Inum_eqs' only: "Suc (Suc 1) * (x + Suc 1 * y)")
oops

text \<open>Let's lift this to formulae and see what happens\<close>

datatype aform = Lt num num  | Eq num num | Ge num num | NEq num num |
  Conj aform aform | Disj aform aform | NEG aform | T | F

primrec linaformsize:: "aform \<Rightarrow> nat"
where
  "linaformsize T = 1"
| "linaformsize F = 1"
| "linaformsize (Lt a b) = 1"
| "linaformsize (Ge a b) = 1"
| "linaformsize (Eq a b) = 1"
| "linaformsize (NEq a b) = 1"
| "linaformsize (NEG p) = 2 + linaformsize p"
| "linaformsize (Conj p q) = 1 + linaformsize p + linaformsize q"
| "linaformsize (Disj p q) = 1 + linaformsize p + linaformsize q"

lemma [measure_function]: "is_measure linaformsize" ..

primrec is_aform :: "aform => nat list => bool"
where
  "is_aform T vs = True"
| "is_aform F vs = False"
| "is_aform (Lt a b) vs = (Inum a vs < Inum b vs)"
| "is_aform (Eq a b) vs = (Inum a vs = Inum b vs)"
| "is_aform (Ge a b) vs = (Inum a vs \<ge> Inum b vs)"
| "is_aform (NEq a b) vs = (Inum a vs \<noteq> Inum b vs)"
| "is_aform (NEG p) vs = (\<not> (is_aform p vs))"
| "is_aform (Conj p q) vs = (is_aform p vs \<and> is_aform q vs)"
| "is_aform (Disj p q) vs = (is_aform p vs \<or> is_aform q vs)"

text\<open>Let's reify and do reflection\<close>
lemma "(3::nat) * x + t < 0 \<and> (2 * x + y \<noteq> 17)"
  apply (reify Inum_eqs' is_aform.simps)
oops

text \<open>Note that reification handles several interpretations at the same time\<close>
lemma "(3::nat) * x + t < 0 \<and> x * x + t * x + 3 + 1 = z * t * 4 * z \<or> x + x + 1 < 0"
  apply (reflection Inum_eqs' is_aform.simps only: "x + x + 1")
oops

text \<open>For reflection we now define a simple transformation on aform: NNF + linum on atoms\<close>

fun linaform:: "aform \<Rightarrow> aform"
where
  "linaform (Lt s t) = Lt (linum s) (linum t)"
| "linaform (Eq s t) = Eq (linum s) (linum t)"
| "linaform (Ge s t) = Ge (linum s) (linum t)"
| "linaform (NEq s t) = NEq (linum s) (linum t)"
| "linaform (Conj p q) = Conj (linaform p) (linaform q)"
| "linaform (Disj p q) = Disj (linaform p) (linaform q)"
| "linaform (NEG T) = F"
| "linaform (NEG F) = T"
| "linaform (NEG (Lt a b)) = Ge a b"
| "linaform (NEG (Ge a b)) = Lt a b"
| "linaform (NEG (Eq a b)) = NEq a b"
| "linaform (NEG (NEq a b)) = Eq a b"
| "linaform (NEG (NEG p)) = linaform p"
| "linaform (NEG (Conj p q)) = Disj (linaform (NEG p)) (linaform (NEG q))"
| "linaform (NEG (Disj p q)) = Conj (linaform (NEG p)) (linaform (NEG q))"
| "linaform p = p"

lemma linaform: "is_aform (linaform p) vs = is_aform p vs"
  by (induct p rule: linaform.induct) (auto simp add: linum)

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps rules: linaform)
oops

declare linaform [reflection]

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps)
oops

text \<open>We now give an example where interpretaions have zero or more than only
  one envornement of different types and show that automatic reification also deals with
  bindings\<close>

datatype rb = BC bool | BAnd rb rb | BOr rb rb

primrec Irb :: "rb \<Rightarrow> bool"
where
  "Irb (BC p) \<longleftrightarrow> p"
| "Irb (BAnd s t) \<longleftrightarrow> Irb s \<and> Irb t"
| "Irb (BOr s t) \<longleftrightarrow> Irb s \<or> Irb t"

lemma "A \<and> (B \<or> D \<and> B) \<and> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B)"
  apply (reify Irb.simps)
oops

datatype rint = IC int | IVar nat | IAdd rint rint | IMult rint rint
  | INeg rint | ISub rint rint

primrec Irint :: "rint \<Rightarrow> int list \<Rightarrow> int"
where
  Irint_Var: "Irint (IVar n) vs = vs ! n"
| Irint_Neg: "Irint (INeg t) vs = - Irint t vs"
| Irint_Add: "Irint (IAdd s t) vs = Irint s vs + Irint t vs"
| Irint_Sub: "Irint (ISub s t) vs = Irint s vs - Irint t vs"
| Irint_Mult: "Irint (IMult s t) vs = Irint s vs * Irint t vs"
| Irint_C: "Irint (IC i) vs = i"

lemma Irint_C0: "Irint (IC 0) vs = 0"
  by simp

lemma Irint_C1: "Irint (IC 1) vs = 1"
  by simp

lemma Irint_Cnumeral: "Irint (IC (numeral x)) vs = numeral x"
  by simp

lemmas Irint_simps = Irint_Var Irint_Neg Irint_Add Irint_Sub Irint_Mult Irint_C0 Irint_C1 Irint_Cnumeral

lemma "(3::int) * x + y * y - 9 + (- z) = 0"
  apply (reify Irint_simps ("(3::int) * x + y * y - 9 + (- z)"))
  oops

datatype rlist = LVar nat | LEmpty | LCons rint rlist | LAppend rlist rlist

primrec Irlist :: "rlist \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> int list"
where
  "Irlist (LEmpty) is vs = []"
| "Irlist (LVar n) is vs = vs ! n"
| "Irlist (LCons i t) is vs = Irint i is # Irlist t is vs"
| "Irlist (LAppend s t) is vs = Irlist s is vs @ Irlist t is vs"

lemma "[(1::int)] = []"
  apply (reify Irlist.simps Irint_simps ("[1] :: int list"))
  oops

lemma "([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs = [y * y - z - 9 + (3::int) * x]"
  apply (reify Irlist.simps Irint_simps ("([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs"))
  oops

datatype rnat = NC nat| NVar nat| NSuc rnat | NAdd rnat rnat | NMult rnat rnat
  | NNeg rnat | NSub rnat rnat | Nlgth rlist

primrec Irnat :: "rnat \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> nat list \<Rightarrow> nat"
where
  Irnat_Suc: "Irnat (NSuc t) is ls vs = Suc (Irnat t is ls vs)"
| Irnat_Var: "Irnat (NVar n) is ls vs = vs ! n"
| Irnat_Neg: "Irnat (NNeg t) is ls vs = 0"
| Irnat_Add: "Irnat (NAdd s t) is ls vs = Irnat s is ls vs + Irnat t is ls vs"
| Irnat_Sub: "Irnat (NSub s t) is ls vs = Irnat s is ls vs - Irnat t is ls vs"
| Irnat_Mult: "Irnat (NMult s t) is ls vs = Irnat s is ls vs * Irnat t is ls vs"
| Irnat_lgth: "Irnat (Nlgth rxs) is ls vs = length (Irlist rxs is ls)"
| Irnat_C: "Irnat (NC i) is ls vs = i"

lemma Irnat_C0: "Irnat (NC 0) is ls vs = 0"
  by simp

lemma Irnat_C1: "Irnat (NC 1) is ls vs = 1"
  by simp

lemma Irnat_Cnumeral: "Irnat (NC (numeral x)) is ls vs = numeral x"
  by simp

lemmas Irnat_simps = Irnat_Suc Irnat_Var Irnat_Neg Irnat_Add Irnat_Sub Irnat_Mult Irnat_lgth
  Irnat_C0 Irnat_C1 Irnat_Cnumeral

lemma "Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs) = length xs"
  apply (reify Irnat_simps Irlist.simps Irint_simps
     ("Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs)"))
  oops

datatype rifm = RT | RF | RVar nat
  | RNLT rnat rnat | RNILT rnat rint | RNEQ rnat rnat
  | RAnd rifm rifm | ROr rifm rifm | RImp rifm rifm| RIff rifm rifm
  | RNEX rifm | RIEX rifm | RLEX rifm | RNALL rifm | RIALL rifm | RLALL rifm
  | RBEX rifm | RBALL rifm

primrec Irifm :: "rifm \<Rightarrow> bool list \<Rightarrow> int list \<Rightarrow> (int list) list \<Rightarrow> nat list \<Rightarrow> bool"
where
  "Irifm RT ps is ls ns \<longleftrightarrow> True"
| "Irifm RF ps is ls ns \<longleftrightarrow> False"
| "Irifm (RVar n) ps is ls ns \<longleftrightarrow> ps ! n"
| "Irifm (RNLT s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns < Irnat t is ls ns"
| "Irifm (RNILT s t) ps is ls ns \<longleftrightarrow> int (Irnat s is ls ns) < Irint t is"
| "Irifm (RNEQ s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns = Irnat t is ls ns"
| "Irifm (RAnd p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<and> Irifm q ps is ls ns"
| "Irifm (ROr p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<or> Irifm q ps is ls ns"
| "Irifm (RImp p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<longrightarrow> Irifm q ps is ls ns"
| "Irifm (RIff p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns = Irifm q ps is ls ns"
| "Irifm (RNEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is ls (x # ns))"
| "Irifm (RIEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is (x # ls) ns)"
| "Irifm (RBEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p (x # ps) is ls ns)"
| "Irifm (RNALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is ls (x#ns))"
| "Irifm (RIALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is (x#ls) ns)"
| "Irifm (RBALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p (x # ps) is ls ns)"

lemma " \<forall>x. \<exists>n. ((Suc n) * length (([(3::int) * x + f t * y - 9 + (- z)] @ []) @ xs) = length xs) \<and> m < 5*n - length (xs @ [2,3,4,x*z + 8 - y]) \<longrightarrow> (\<exists>p. \<forall>q. p \<and> q \<longrightarrow> r)"
  apply (reify Irifm.simps Irnat_simps Irlist.simps Irint_simps)
oops

text \<open>An example for equations containing type variables\<close>

datatype prod = Zero | One | Var nat | Mul prod prod
  | Pw prod nat | PNM nat nat prod

primrec Iprod :: " prod \<Rightarrow> ('a::linordered_idom) list \<Rightarrow>'a"
where
  "Iprod Zero vs = 0"
| "Iprod One vs = 1"
| "Iprod (Var n) vs = vs ! n"
| "Iprod (Mul a b) vs = Iprod a vs * Iprod b vs"
| "Iprod (Pw a n) vs = Iprod a vs ^ n"
| "Iprod (PNM n k t) vs = (vs ! n) ^ k * Iprod t vs"

datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
  | Or sgn sgn | And sgn sgn

primrec Isgn :: "sgn \<Rightarrow> ('a::linordered_idom) list \<Rightarrow> bool"
where
  "Isgn Tr vs \<longleftrightarrow> True"
| "Isgn F vs \<longleftrightarrow> False"
| "Isgn (ZeroEq t) vs \<longleftrightarrow> Iprod t vs = 0"
| "Isgn (NZeroEq t) vs \<longleftrightarrow> Iprod t vs \<noteq> 0"
| "Isgn (Pos t) vs \<longleftrightarrow> Iprod t vs > 0"
| "Isgn (Neg t) vs \<longleftrightarrow> Iprod t vs < 0"
| "Isgn (And p q) vs \<longleftrightarrow> Isgn p vs \<and> Isgn q vs"
| "Isgn (Or p q) vs \<longleftrightarrow> Isgn p vs \<or> Isgn q vs"

lemmas eqs = Isgn.simps Iprod.simps

lemma "(x::'a::{linordered_idom}) ^ 4 * y * z * y ^ 2 * z ^ 23 > 0"
  apply (reify eqs)
  oops

end


theory Check
  imports Submission
begin

lemma hoare_complete: "(\<Turnstile> {P}c{Q}) \<Longrightarrow> \<turnstile>{Q} {P}c{Q}"
  by (rule Submission.hoare_complete)

theorem hoare_sound_complete: "\<turnstile>{Q} {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
  by (rule Submission.hoare_sound_complete)

end


section \<open>Breadth First Search\<close>
theory Augmenting_Path_BFS
imports
  (* Maxflow_Lib.Refine_Add_Fofu *)
  Graph_Impl
  "../../Refine_Foreach"
(*  "NREST.RefineMonadicVCG" *)
  "../../Refine_Imperative_HOL/IICF/IICF"
  "../../Refine_Heuristics"
begin

  text \<open>
    In this theory, we present a verified breadth-first search
    with an efficient imperative implementation.
    It is parametric in the successor function.
    \<close>

  subsection \<open>Algorithm\<close>
  locale pre_bfs_invar = Graph +
    fixes src dst :: node
  begin

    abbreviation "ndist v \<equiv> min_dist src v"

    definition Vd :: "nat \<Rightarrow> node set"
    where
      "\<And>d. Vd d \<equiv> {v. connected src v \<and> ndist v = d}"

    lemma Vd_disj: "\<And>d d'. d\<noteq>d' \<Longrightarrow> Vd d \<inter> Vd d' = {}"
      by (auto simp: Vd_def)

    lemma src_Vd0[simp]: "Vd 0 = {src}"
      by (auto simp: Vd_def)

    lemma in_Vd_conv: "v\<in>Vd d \<longleftrightarrow> connected src v \<and> ndist v = d"
      by (auto simp: Vd_def)

    lemma Vd_succ:
      assumes "u\<in>Vd d"
      assumes "(u,v)\<in>E"
      assumes "\<forall>i\<le>d. v\<notin>Vd i"
      shows "v\<in>Vd (Suc d)"
      using assms
      by (metis connected_append_edge in_Vd_conv le_SucE min_dist_succ)

  end

  locale valid_PRED = pre_bfs_invar +
    fixes PRED :: "node \<rightharpoonup> node"
    assumes SRC_IN_V[simp]: "src\<in>V"
    assumes FIN_V[simp, intro!]: "finite V"
    assumes PRED_src[simp]: "PRED src = Some src"
    assumes PRED_dist: "\<lbrakk>v\<noteq>src; PRED v = Some u\<rbrakk> \<Longrightarrow> ndist v = Suc (ndist u)"
    assumes PRED_E: "\<lbrakk>v\<noteq>src; PRED v = Some u\<rbrakk> \<Longrightarrow> (u,v)\<in>E"
    assumes PRED_closed: "\<lbrakk> PRED v = Some u \<rbrakk> \<Longrightarrow> u\<in>dom PRED"
  begin
    lemma FIN_E[simp, intro!]: "finite E" using E_ss_VxV by simp
    lemma FIN_succ[simp, intro!]: "finite (E``{u})"
      by (auto intro: finite_Image)
  end

  locale nf_invar' = valid_PRED c src dst PRED for c src dst
    and PRED :: "node \<rightharpoonup> node"
    and C N :: "node set"
    and d :: nat
    +
    assumes VIS_eq: "dom PRED = N \<union> {u. \<exists>i\<le>d. u\<in>Vd i}"
    assumes C_ss: "C \<subseteq> Vd d"
    assumes N_eq: "N = Vd (d+1) \<inter> E``(Vd d - C)"

    assumes dst_ne_VIS: "dst \<notin> dom PRED"

  locale nf_invar = nf_invar' +
    assumes empty_assm: "C={} \<Longrightarrow> N={}"

  locale f_invar = valid_PRED c src dst PRED for c src dst
    and PRED :: "node \<rightharpoonup> node"
    and d :: nat
    +
    assumes dst_found: "dst \<in> dom PRED \<inter> Vd d"

  context Graph begin

    abbreviation "outer_loop_invar src dst \<equiv> \<lambda>(f,PRED,C,N,d).
      (f \<longrightarrow> f_invar c src dst PRED d) \<and>
      (\<not>f \<longrightarrow> nf_invar c src dst PRED C N d)

      "
    abbreviation "assn1 src dst \<equiv> \<lambda>(f,PRED,C,N,d).
      \<not>f \<and> nf_invar' c src dst PRED C N d"

end

locale Pre_BFS_Impl = Graph +
  fixes  set_insert_time map_dom_member_time :: nat
    and   get_succs_list_time :: nat and  map_update_time set_pick_extract_time set_empty_time  :: nat
    and set_isempty_time init_state_time init_get_succs_list_time :: nat
  assumes [simp]: "set_pick_extract_time > 0"
begin

  definition (in -) "hh v1 v2 v3 == (v1 + ((v2 + v3) + (Suc 0)))"

  definition (in -) add_succs_spec_time_aux   where  "add_succs_spec_time_aux cs v1 v2 v3 = (cs * hh v1 v2 v3)"
  abbreviation  "hhh == hh map_dom_member_time set_insert_time map_update_time + get_succs_list_time"
  abbreviation "add_succs_spec_time cs == add_succs_spec_time_aux cs map_dom_member_time set_insert_time map_update_time"
  lemma add_succs_spec_time_mono: "n \<le> m \<Longrightarrow> add_succs_spec_time n \<le> add_succs_spec_time m"
    unfolding add_succs_spec_time_aux_def
    using mult_le_cancel2 by blast

  definition "add_succs_spec dst succ v PRED N \<equiv> ASSERT (N \<subseteq> dom PRED) \<then>
    SPECT (emb (\<lambda>(f,PRED',N').
      case f of
        False \<Rightarrow> dst \<notin> succ - dom PRED
          \<and> PRED' = map_mmupd PRED (succ - dom PRED) v
          \<and> N' = N \<union> (succ - dom PRED)
      | True \<Rightarrow> dst \<in> succ - dom PRED
        \<and> PRED \<subseteq>\<^sub>m PRED'
        \<and> PRED' \<subseteq>\<^sub>m map_mmupd PRED (succ - dom PRED) v
        \<and> dst\<in>dom PRED'
  ) (add_succs_spec_time (card succ))) "

  definition (in Graph) "max_dist src \<equiv> Max (min_dist src`V)"

  definition "Vvisited src C d \<equiv> (\<Union>x\<in>{0..<d}. pre_bfs_invar.Vd c src x) \<union> (pre_bfs_invar.Vd c src d - C)"
  abbreviation "outedges Vs \<equiv> {(x, y). (x, y) \<in> E \<and> x \<in> Vs}"
  abbreviation "inedges Vs \<equiv> {(y,x). (y,x) \<in> E \<and> x \<in> Vs}"
  lemma u: "\<And>Vs. inedges Vs = {(y,x). (x,y) \<in> E\<inverse> \<and> x \<in> Vs}" by simp

  lemma card_outedges_singleton: "card (outedges {x}) = card (E``{x})"
  proof -
    have *: "outedges {x} = {x} \<times>  E``{x}" unfolding u by auto
    show ?thesis unfolding * card_cartesian_product_singleton ..
  qed

  lemma card_inedges_singleton: "card (inedges {x}) = card (E\<inverse>``{x})"
  proof -
    thm card_cartesian_product_singleton
    have "inedges {x} = E\<inverse>``{x} \<times> {x}" unfolding u by auto
    then have "card (inedges {x}) = card (E\<inverse>``{x} \<times> {x})" by simp
    also have "\<dots> = card (E\<inverse>``{x})" by(simp add: card_cartesian_product)
    finally show ?thesis .
  qed

abbreviation "bod \<equiv> (set_pick_extract_time + init_get_succs_list_time
                       + 2 * set_isempty_time + set_empty_time)"

definition Te :: "node \<Rightarrow> bool \<times> (nat \<Rightarrow> nat option) \<times> nat set \<times> nat set \<times> nat
   \<Rightarrow> nat" where "Te src = (\<lambda>(f,PRED,C,N,d). if f then 0
         else (card (E - (outedges (Vvisited src C d))) * (hhh+bod))
              +  (card (E - (inedges (Vvisited src C d))) * (get_succs_list_time))

                 + (card N) * (bod) + card C * bod  )"

  definition pre_bfs :: "node \<Rightarrow> node \<Rightarrow> (nat \<times> (node\<rightharpoonup>node)) option nrest"
    where "pre_bfs src dst \<equiv> do {
        s \<leftarrow> SPECT [(False,[src\<mapsto>src],{src},{},0::nat) \<mapsto> init_state_time];
    (f,PRED,_,_,d) \<leftarrow> monadic_WHILEIE (outer_loop_invar src dst) (Te src)
      (\<lambda>(f,PRED,C,N,d). SPECT [ f=False \<and> C\<noteq>{} \<mapsto> set_isempty_time])
      (\<lambda>(f,PRED,C,N,d). do {
        ASSERT (card C\<le>card V);
        (v,C) \<leftarrow> mop_set_pick_extract (\<lambda>_. set_pick_extract_time)  C;
        ASSERT (v\<in>V);
        succ \<leftarrow> SPECT (emb (\<lambda>l. distinct l \<and> set l = E``{v}) (enat ( init_get_succs_list_time + ((card (E``{v})) + (card (E\<inverse>``{v}))  )*get_succs_list_time)));
        ASSERT (distinct succ);
        ASSERT (finite V);
        ASSERT (dom PRED \<subseteq> V);
        ASSERT (set succ \<subseteq> V);
        ASSERT (N \<subseteq> V);
        (f,PRED,N) \<leftarrow> add_succs_spec dst (set succ) v PRED N;
        if f then
          RETURNT (f,PRED,C,N,d+1)
        else do {
          ASSERT (assn1 src dst (f,PRED,C,N,d));
          b \<leftarrow> mop_set_isempty (\<lambda>_. set_isempty_time) C;
          if (b) then do {
            C \<leftarrow> RETURNT N;
            N \<leftarrow> mop_set_empty (\<lambda>_. set_empty_time);
            d \<leftarrow> RETURNT (d+1);
            RETURNT (f,PRED,C,N,d)
          } else RETURNT (f,PRED,C,N,d)
        }
      })
      s;
    if f then RETURNT (Some (d, PRED)) else RETURNT None
    }"

  subsection "Correctness Proof"

  lemma (in nf_invar') ndist_C[simp]: "\<lbrakk>v\<in>C\<rbrakk> \<Longrightarrow> ndist v = d"
    using C_ss by (auto simp: Vd_def)
  lemma (in nf_invar) CVdI: "\<lbrakk>u\<in>C\<rbrakk> \<Longrightarrow> u\<in>Vd d"
    using C_ss by (auto)

  lemma (in nf_invar) inPREDD:
    "\<lbrakk>PRED v = Some u\<rbrakk> \<Longrightarrow> v\<in>N \<or> (\<exists>i\<le>d. v\<in>Vd i)"
    using VIS_eq by (auto)

  lemma (in nf_invar') C_ss_VIS: "\<lbrakk>v\<in>C\<rbrakk> \<Longrightarrow> v\<in>dom PRED"
    using C_ss VIS_eq by blast

  lemma (in nf_invar) invar_succ_step:
    assumes "v\<in>C"
    assumes "dst \<notin> E``{v} - dom PRED"
    shows "nf_invar' c src dst
      (map_mmupd PRED (E``{v} - dom PRED) v)
      (C-{v})
      (N \<union> (E``{v} - dom PRED))
      d"
  proof -
    from C_ss_VIS[OF \<open>v\<in>C\<close>] dst_ne_VIS have "v\<noteq>dst" by auto

    show ?thesis
      using \<open>v\<in>C\<close> \<open>v\<noteq>dst\<close>
      apply unfold_locales
      apply simp
      apply simp
      apply (auto simp: map_mmupd_def) []

      apply (erule map_mmupdE)
      using PRED_dist apply blast
      apply (unfold VIS_eq) []
      apply clarify
      apply (metis CVdI Vd_succ in_Vd_conv)

      using PRED_E apply (auto elim!: map_mmupdE) []
      using PRED_closed apply (auto elim!: map_mmupdE dest: C_ss_VIS) []

      using VIS_eq apply auto []
      using C_ss apply auto []

      apply (unfold N_eq) []
      apply (frule CVdI)
      apply (auto) []
      apply (erule (1) Vd_succ)
      using VIS_eq apply (auto) []
      apply (auto dest!: inPREDD simp: N_eq in_Vd_conv) []

      using dst_ne_VIS assms(2) apply auto []
      done
  qed

  lemma invar_init: "\<lbrakk>src\<noteq>dst; src\<in>V; finite V\<rbrakk>
    \<Longrightarrow> nf_invar c src dst [src \<mapsto> src] {src} {} 0"
    apply unfold_locales
    apply (auto)
    apply (auto simp: pre_bfs_invar.Vd_def split: if_split_asm)
    done

  lemma (in nf_invar) invar_exit:
    assumes "dst\<in>C"
    shows "f_invar c src dst PRED d"
    apply unfold_locales
    using assms VIS_eq C_ss by auto

  lemma (in nf_invar) invar_C_ss_V: "u\<in>C \<Longrightarrow> u\<in>V"
    apply (drule CVdI)
    apply (auto simp: in_Vd_conv connected_inV_iff)
    done

  lemma (in nf_invar) invar_N_ss_Vis: "u\<in>N \<Longrightarrow> \<exists>v. PRED u = Some v"
    using VIS_eq by auto

  lemma (in pre_bfs_invar) Vdsucinter_conv[simp]:
    "Vd (Suc d) \<inter> E `` Vd d = Vd (Suc d)"
    apply (auto)
    by (metis Image_iff in_Vd_conv min_dist_suc)

  lemma (in nf_invar') invar_shift:
    assumes [simp]: "C={}"
    shows "nf_invar c src dst PRED N {} (Suc d)"
    apply unfold_locales
    using VIS_eq N_eq[simplified] apply (auto simp add: le_Suc_eq) []
    using N_eq apply auto []
    using N_eq[simplified] apply auto []
    using dst_ne_VIS apply auto []
    apply simp
    done

  lemma (in nf_invar') invar_restore:
    assumes [simp]: "C\<noteq>{}"
    shows "nf_invar c src dst PRED C N d"
    apply unfold_locales by auto

  definition (in Graph) "bfs_spec src dst r \<equiv> (
    case r of None \<Rightarrow> \<not> connected src dst
            | Some (d,PRED) \<Rightarrow> connected src dst
                \<and> min_dist src dst = d
                \<and> valid_PRED c src PRED
                \<and> dst\<in>dom PRED)"

  lemma (in f_invar) invar_found:
    shows "bfs_spec src dst (Some (d,PRED))"
    unfolding bfs_spec_def
    apply simp
    using dst_found
    apply (auto simp: in_Vd_conv)
    by unfold_locales

  lemma (in nf_invar) invar_not_found:
    assumes [simp]: "C={}"
    shows "bfs_spec src dst None"
    unfolding bfs_spec_def
    apply simp
  proof (rule notI)
    have [simp]: "N={}" using empty_assm by simp

    assume C: "connected src dst"
    then obtain d' where dstd': "dst \<in> Vd d'"
      by (auto simp: in_Vd_conv)

    txt \<open>We make a case-distinction whether \<open>d'\<le>d\<close>:\<close>
    have "d'\<le>d \<or> Suc d \<le> d'" by auto
    moreover {
      assume "d'\<le>d"
      with VIS_eq dstd' have "dst \<in> dom PRED" by auto
      with dst_ne_VIS have False by auto
    } moreover {
      assume "Suc d \<le> d'"
      txt \<open>In the case \<open>d+1 \<le> d'\<close>, we also obtain a node
        that has a shortest path of length \<open>d+1\<close>:\<close>
      with min_dist_le[OF C] dstd' obtain v' where "v' \<in> Vd (Suc d)"
        by (auto simp: in_Vd_conv)
      txt \<open>However, the invariant states that such nodes are either in
        \<open>N\<close> or are successors of \<open>C\<close>. As \<open>N\<close>
        and \<open>C\<close> are both empty, we again get a contradiction.\<close>
      with N_eq have False by auto
    } ultimately show False by blast
  qed

  lemma (in Graph) map_le_mp: "\<lbrakk>m\<subseteq>\<^sub>mm'; m k = Some v\<rbrakk> \<Longrightarrow> m' k = Some v"
    by (force simp: map_le_def)

  lemma (in nf_invar) dst_notin_Vdd[intro, simp]: "i\<le>d \<Longrightarrow> dst\<notin>Vd i"
    using VIS_eq dst_ne_VIS by auto

  lemma (in nf_invar) invar_exit':
    assumes "u\<in>C" "(u,dst) \<in> E" "dst \<in> dom PRED'"
    assumes SS1: "PRED \<subseteq>\<^sub>m PRED'"
      and SS2: "PRED' \<subseteq>\<^sub>m map_mmupd PRED (E``{u} - dom PRED) u"
    shows "f_invar c src dst PRED' (Suc d)"
    apply unfold_locales
    apply simp_all

    using map_le_mp[OF SS1 PRED_src] apply simp

    apply (drule map_le_mp[OF SS2])
    apply (erule map_mmupdE)
    using PRED_dist apply auto []
    apply (unfold VIS_eq) []
    apply clarify
    using \<open>u\<in>C\<close>
    apply (metis CVdI Vd_succ in_Vd_conv)

    apply (drule map_le_mp[OF SS2])
    using PRED_E apply (auto elim!: map_mmupdE) []

    apply (drule map_le_mp[OF SS2])
    apply (erule map_mmupdE)
    using map_le_implies_dom_le[OF SS1]
    using PRED_closed apply (blast) []
    using C_ss_VIS[OF \<open>u\<in>C\<close>] map_le_implies_dom_le[OF SS1] apply blast
    using \<open>dst \<in> dom PRED'\<close> apply simp

    using \<open>u\<in>C\<close> CVdI[OF \<open>u\<in>C\<close>] \<open>(u,dst)\<in>E\<close>
    apply (auto) []
    apply (erule (1) Vd_succ)
    using VIS_eq apply (auto) []
    done

  lemma (in nf_invar) Vd_ss_V: "Vd d \<subseteq> V"
    by (auto simp: Vd_def connected_inV_iff)

  lemma (in nf_invar) finite_C[simp, intro!]: "finite C"
    using C_ss FIN_V Vd_ss_V by (blast intro: finite_subset)

  lemma (in nf_invar) finite_succ: "finite (E``{u})"
    by auto

  definition (in -) pre_bfs_time_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
    "pre_bfs_time_aux cE v1 v2 v3 v4 v5 = v1 + v2 + ( cE * (v3+v4+v5) + v4) "

  lemma (in -)  pre_bfs_time_aux_mono: "cE1 \<le> cE2 \<Longrightarrow> pre_bfs_time_aux cE1 v1 v2 v3 v4 v5
              \<le> pre_bfs_time_aux cE2 v1 v2 v3 v4 v5"
    by(auto simp: pre_bfs_time_aux_def)

  abbreviation "pre_bfs_time cE \<equiv> pre_bfs_time_aux cE init_state_time set_isempty_time hhh bod get_succs_list_time"

  lemma pre_bfs_time_progress: "pre_bfs_time cE > 0"   by (simp add: pre_bfs_time_aux_def)

  lemma Te_start_ub: assumes "valid_PRED c src PRED"
    shows "set_isempty_time +  init_state_time + (Te src (False, [src \<mapsto> src], {src}, {}, 0)) \<le> pre_bfs_time (card E)"
  proof -
    from assms have "finite E"
      using valid_PRED.FIN_E by blast
    then have "card (E - outedges (Vvisited src {src} 0))  \<le> card E"
          "card (E - inedges (Vvisited src {src} 0))  \<le> card E"
      by(auto intro: card_mono)
    then have "Te src (False, [src \<mapsto> src], {src}, {}, 0) \<le> card E * (hhh + bod) + card E * get_succs_list_time + bod"
      apply (auto simp add: Te_def pre_bfs_time_aux_def )
      using mlex_leI mult_le_mono1 by blast
    also have "set_isempty_time +  init_state_time + \<dots> \<le>  pre_bfs_time (card E)"
      apply(auto simp: pre_bfs_time_aux_def)
      by (simp add: distrib_left)
    finally show ?thesis by auto
  qed

  lemma TeTF_[simp]: "(Te src (True, a1, b1, c1, d1) \<le>  Te src (False, x, y, z, f)) \<longleftrightarrow> True"
      unfolding Te_def by simp

  lemma hlp: "\<And>a b c::enat. a \<le> c \<Longrightarrow> enat ((a::nat)-b) \<le> c"
   using diff_le_self dual_order.trans enat_ord_simps(1) by blast

  lemma hlp_nat: "\<And>a b c::nat. a \<le> c \<Longrightarrow> ((a)-b) \<le> c"
   using diff_le_self dual_order.trans enat_ord_simps(1) by blast

  lemma (in nf_invar) cardC: "card C \<le> card V"
    by(auto simp: invar_C_ss_V intro!: card_mono)

  lemma (in nf_invar) cardN'_: "x\<in>C \<Longrightarrow> (N \<union> (E `` {x} - dom PRED)) \<subseteq>  V"
    by (smt Diff_iff Graph.connected_inV_iff Graph.succ_ss_V Int_iff N_eq SRC_IN_V UnE mem_Collect_eq pre_bfs_invar.Vd_def subsetCE subsetI)

  lemma (in nf_invar) cardN':  "x\<in>C \<Longrightarrow> card (N \<union> (E `` {x} - dom PRED)) \<le> card V"
    apply(rule card_mono[OF FIN_V cardN'_]) by simp

  lemma   Te_decr_succ_step: assumes "nf_invar c src dst PRED C N d"
      and Cx: "C = {x}"
    shows
      "Te src(False, map_mmupd PRED (E `` {x} - dom PRED) x, N \<union> (E `` {x} - dom PRED), {}, Suc d)
      \<le> Te src (False, PRED, C, N, d)" (is "?L \<le> ?R")
    and "set_isempty_time + set_pick_extract_time +  (init_get_succs_list_time + (card (E `` {x}) + card (E\<inverse> `` {x})) * get_succs_list_time) + add_succs_spec_time (card (E `` {x}))  + set_isempty_time + set_empty_time
      \<le> Te src (False, PRED, C, N, d) -
         Te src
          (False, map_mmupd PRED (E `` {x} - dom PRED) x, N \<union> (E `` {x} - dom PRED), {}, Suc d)" (is "?P \<le> _")
  proof -
    from assms(2) have xC: "x\<in>C" by auto
    from  assms(1) have fE: "finite E" unfolding nf_invar_def nf_invar'_def
      using valid_PRED.FIN_E  by auto
    from assms(1) have fC: "finite C"
      using nf_invar.finite_C by blast

    have i: "(pre_bfs_invar.Vd c src (Suc d) - (N \<union> (E `` {x} - dom PRED))) = {}"
      unfolding nf_invar'.N_eq[OF assms(1)[unfolded nf_invar_def, THEN conjunct1]] assms(2)
      apply auto
      subgoal using pre_bfs_invar.Vdsucinter_conv by fastforce
      subgoal
        by (metis IntE Suc_n_not_le_n \<open>N = pre_bfs_invar.Vd c src (d + 1) \<inter> E `` (pre_bfs_invar.Vd c src d - C)\<close> assms(1) assms(2) nf_invar.inPREDD pre_bfs_invar.in_Vd_conv)
      done

    have k: "Vvisited src (N \<union> (E `` {x} - dom PRED)) (Suc d)
        = Vvisited src {} d"
      unfolding Vvisited_def unfolding i by (simp add: Un_commute atLeast0_lessThan_Suc)

    have l: "?L \<le> card (E - outedges (Vvisited src {} d)) * (hhh + bod) + card (E - inedges (Vvisited src {} d)) * get_succs_list_time +
      (card N) *(bod)  + (card (E `` {x} - dom PRED)) * (bod)"
      unfolding Te_def                        apply simp unfolding k
      apply (subst card_Un_disjoint)
      subgoal using assms(1)
        by (meson Efin_imp_Vfin xC fE finite_subset le_sup_iff nf_invar.cardN'_)
      subgoal using fE by auto   subgoal using assms(1)
        by (metis (no_types, lifting) DiffD2 Int_emptyI UnCI nf_invar'.VIS_eq nf_invar_def)
      by (auto simp: add_mult_distrib)

    have Ein: "E - inedges (Vvisited src C d) = (E - inedges (Vvisited src {} d)) \<union> inedges C"
      unfolding Vvisited_def apply auto
      by (metis assms(1) nat_neq_iff nf_invar.CVdI pre_bfs_invar.in_Vd_conv)
    have Ein2: "card (E - inedges (Vvisited src {} d) \<union> inedges C) = card (E - inedges (Vvisited src {} d)) + card (inedges C)"
      apply(rule card_Un_disjoint) apply rule apply fact
      subgoal using \<open>finite C\<close>      by (metis (no_types, lifting) Collect_mem_eq Diff_iff Ein UnCI \<open>finite E\<close> finite_subset mem_Collect_eq subsetI)
      apply (auto simp: Vvisited_def)    using assms(1) nf_invar.CVdI by blast

    have E: "E - outedges (Vvisited src C d) = (E - outedges (Vvisited src {} d)) \<union> outedges C"
      unfolding Vvisited_def apply auto
      by (metis assms(1) nat_neq_iff nf_invar.CVdI pre_bfs_invar.in_Vd_conv)
    have E2: "card (E - outedges (Vvisited src {} d) \<union> outedges C) = card (E - outedges (Vvisited src {} d)) + card (outedges C)"
      apply(rule card_Un_disjoint) apply rule apply fact
      subgoal using \<open>finite C\<close>      by (metis (no_types, lifting) Collect_mem_eq Diff_iff E UnCI \<open>finite E\<close> finite_subset mem_Collect_eq subsetI)
      apply (auto simp: Vvisited_def)    using assms(1) nf_invar.CVdI by blast

    have "card (E `` {x} - dom PRED) \<le> card (E `` {x}) " apply(rule card_mono) using fE by auto
    also have "\<dots> = card (outedges C)" using card_outedges_singleton Cx  by simp
    finally have c: "card (E `` {x} - dom PRED) \<le> card (outedges C)" by auto

    have r: "(card (E - outedges (Vvisited src {} d)) ) * (hhh + bod)  + card (outedges C) * (hhh+bod)
            + card (E - inedges (Vvisited src {} d)) * get_succs_list_time + card (inedges C) * get_succs_list_time  +
         (card N)*(bod) + (card C) * (bod) \<le> ?R"
      unfolding Te_def apply clarsimp   unfolding E E2 Ein Ein2
      by (simp add: distrib_right)

    show "?L \<le> ?R" apply(rule order.trans[OF l]) apply(rule order.trans[OF _ r])  using c apply auto
      by (simp add: mult_le_mono trans_le_add1)

    show "?P \<le> ?R - ?L" apply(rule order.trans[OF _ diff_le_mono[OF r]] )
        apply(rule order.trans[OF _ diff_le_mono2[OF l]] )
        unfolding assms(2) card_outedges_singleton card_inedges_singleton apply (simp add:    add_succs_spec_time_aux_def )
      apply(rule dual_order.trans[OF diff_le_mono2[where n="card (E `` {x}) * bod"]])
      subgoal by (auto intro!: card_mono simp: fE)
      apply (simp add: add.commute add.left_commute distrib_left distrib_right)
      done
  qed

  lemma hl: "x \<in> C \<Longrightarrow> C \<noteq> {}" by auto

  lemma Te_decr_level_step: assumes "nf_invar c src dst PRED C N d"
    "C \<noteq> {}" and  xC: "x \<in> C"
  shows "Te src
             (False, map_mmupd PRED (E `` {x} - dom PRED) x, C - {x},
              N \<union> (E `` {x} - dom PRED), d)
      \<le> Te src (False, PRED, C, N, d)" (is "?L \<le> ?R")
    and "set_isempty_time + set_pick_extract_time  + (init_get_succs_list_time+ (card (E `` {x}) + card (E\<inverse> `` {x})) * get_succs_list_time) + add_succs_spec_time (card (E `` {x}))  + set_isempty_time
         \<le> Te src (False, PRED, C, N, d) -
            Te src
             (False, map_mmupd PRED (E `` {x} - dom PRED) x, C - {x},
              N \<union> (E `` {x} - dom PRED), d)" (is "?P \<le> _")
  proof -
    from  assms(1) have fE: "finite E" unfolding nf_invar_def nf_invar'_def
      using valid_PRED.FIN_E  by auto
    from assms(1) have fC: "finite C"
      using nf_invar.finite_C by blast

    have f: "outedges {x} = {x} \<times> E `` {x}" by auto
    have f2: "{(xa, y). (xa, y) \<in> E \<and> xa = x} = {x} \<times> E `` {x}" by auto

    have v: "Vvisited src (C - {x}) d = Vvisited src C d \<union> {x}" unfolding Vvisited_def apply auto
      using assms(1) nf_invar.CVdI xC by blast
    have ve: " Vvisited src C d \<inter> {x} = {}" unfolding Vvisited_def
      by (smt Diff_iff Int_emptyI UN_iff UnE assms(1) atLeastLessThan_iff less_not_refl nf_invar.CVdI pre_bfs_invar.in_Vd_conv singletonD xC)

    have 1: "(E - outedges (Vvisited src (C - {x}) d)) \<union> (outedges {x}) = (E - outedges (Vvisited src C d))"
      unfolding v using ve by blast

    have 11: "card ((E - outedges (Vvisited src (C - {x}) d)) \<union> (outedges {x}))
        = card (E - outedges (Vvisited src (C - {x}) d)) + card (outedges {x})"
      apply(rule card_Un_disjoint) subgoal using fE by auto
      subgoal apply(rule finite_subset[OF _ fE]) by auto
      subgoal apply auto
        by (simp add: v)
      done

    have in1: "(E - inedges (Vvisited src (C - {x}) d)) \<union> (inedges {x}) = (E - inedges (Vvisited src C d))"
      unfolding v using ve by blast

    have in11: "card ((E - inedges (Vvisited src (C - {x}) d)) \<union> (inedges {x}))
        = card (E - inedges (Vvisited src (C - {x}) d)) + card (inedges {x})"
      apply(rule card_Un_disjoint) subgoal using fE by auto
      subgoal apply(rule finite_subset[OF _ fE]) by auto
      subgoal apply auto
        by (simp add: v)
      done

    have fN: "finite N"
      by (meson Efin_imp_Vfin assms(1) fE le_sup_iff nf_invar.cardN'_ rev_finite_subset xC)

    have "(card (E - outedges (Vvisited src (C - {x}) d)))* (hhh + bod) + (card (E `` {x})) * (hhh + bod)
        + (card (E - inedges (Vvisited src (C - {x}) d)))* get_succs_list_time + (card (E\<inverse> `` {x})) * get_succs_list_time
           + card N * bod + card C * bod
            = card (E - outedges (Vvisited src C d)) * (hhh + bod) +
            card (E - inedges (Vvisited src C d)) * get_succs_list_time  + (card N) *(bod) + card C * bod"
       unfolding 1[symmetric] 11[unfolded card_outedges_singleton] in1[symmetric] in11[unfolded card_inedges_singleton]
      by (simp add: add_mult_distrib)
    also have r: "... = ?R" unfolding Te_def by simp
    finally have r: " ?R= (card (E - outedges (Vvisited src (C - {x}) d)))* (hhh + bod) + (card (E `` {x})) * (hhh + bod)
        + (card (E - inedges (Vvisited src (C - {x}) d)))* get_succs_list_time + (card (E\<inverse> `` {x})) * get_succs_list_time
           + card N * bod + card C * bod"
        by auto

      have l1: "?L \<le> card (E - outedges (Vvisited src (C - {x}) d)) * (hhh + bod) +
                card (E - inedges (Vvisited src (C - {x}) d)) * get_succs_list_time +
               (card N + card (E `` {x}))*(bod) + card (C - {x}) * bod"
      unfolding Te_def apply simp apply(rule order.trans[OF card_Un_le]) apply simp apply(rule card_mono) using fE fN by auto
    also have l: "\<dots> \<le> (card (E - outedges (Vvisited src (C - {x}) d)) + card (E `` {x})) * (hhh + bod)
                + card (E - inedges (Vvisited src (C - {x}) d)) * get_succs_list_time
                 + (card N) * (bod) + card (C - {x}) * bod"
      by (simp add: add_mult_distrib)
    finally have l: "?L \<le> (card (E - outedges (Vvisited src (C - {x}) d)) + card (E `` {x})) * (hhh + bod)
                + card (E - inedges (Vvisited src (C - {x}) d)) * get_succs_list_time
               + (card N) * (bod) + card (C - {x}) * bod" .

    show "?L \<le> ?R" apply(rule order.trans[OF l]) unfolding  r apply (simp add: add_mult_distrib)
      apply(rule order.trans[where b ="card C * bod "])
      subgoal apply simp apply(rule card_mono) using fC by auto
      subgoal by simp
      done
    have z: "card {(xa, y). (xa, y) \<in> E \<and> xa = x} = card (E `` {x})" unfolding f2 card_cartesian_product_singleton by auto

    have k: "(card N + card (E `` {x})) * bod  = card N * bod + card (E `` {x}) * bod"
      by (simp add: add_mult_distrib2 mult.commute)
    have k2: "card (E `` {x}) * (hhh + bod)   = card (E `` {x}) * hhh + card (E `` {x}) *bod "
      by (simp add: add_mult_distrib2 mult.commute)
    have k3: "(card (E `` {x}) + card (E\<inverse> `` {x})) * get_succs_list_time = card (E `` {x}) * get_succs_list_time + card (E\<inverse> `` {x}) * get_succs_list_time"
      by (simp add: add_mult_distrib2 mult.commute)
    have d: "(card C - card (C - {x})) = 1" using xC fC
      by (simp add: Suc_leI assms(2) card_gt_0_iff)

    show "?P \<le> ?R - ?L"  unfolding r
        apply(rule order.trans[OF _ diff_le_mono2[OF l1]] )
      apply (simp add:  add_succs_spec_time_aux_def )
      unfolding k unfolding k2 unfolding k3 apply simp
      apply(subst (3) add.assoc[symmetric])
      apply(subst diff_add_assoc)  apply (auto intro!: card_mono simp: d fC diff_mult_distrib[symmetric])
      by (simp add: add_mult_distrib2)
  qed

  lemma (in nf_invar) Cge1: "x \<in> C \<Longrightarrow> card C \<ge> 1"
    using card_0_eq finite_C by force

  lemma   Te_pays_exit: assumes "nf_invar c src dst PRED C N d"
    "x \<in> C"
       shows "set_isempty_time + set_pick_extract_time  + (init_get_succs_list_time + (card (E `` {x}) + card (E\<inverse> `` {x})) * get_succs_list_time) + add_succs_spec_time (card (E `` {x}))
         \<le> Te src (False, PRED, C, N, d) - Te src (True, PRED', C - {x}, N', Suc d)" (is "?P \<le> ?R - ?L")
  proof -
    from  assms(1) have fE: "finite E" unfolding nf_invar_def nf_invar'_def
      using valid_PRED.FIN_E  by auto
    have l: "?L = 0" by(auto simp: Te_def)

    have "card (E``{x}) = card (outedges {x})" unfolding card_outedges_singleton ..
    also
    from assms(2) have "outedges {x} \<subseteq> E - outedges (Vvisited src C d)"
      unfolding Vvisited_def apply auto
      by (metis assms(1) less_not_refl nf_invar.CVdI pre_bfs_invar.in_Vd_conv)
    then have "card (outedges {x}) \<le> card (E - outedges (Vvisited src C d))"
      apply (rule card_mono[rotated]) apply rule apply fact done
    finally have out: "card (E``{x}) \<le> card (E - outedges (Vvisited src C d))" .

    then have outr1: "card (E - outedges (Vvisited src C d)) * (hhh + bod) \<ge> card (E``{x}) * (hhh+bod)"
      by(simp only: mult_le_mono)

    have "card (E\<inverse>``{x}) = card (inedges {x})" unfolding card_inedges_singleton ..
    also
    from assms(2) have "inedges {x} \<subseteq> E - inedges (Vvisited src C d)"
      unfolding Vvisited_def apply auto
      by (metis assms(1) less_not_refl nf_invar.CVdI pre_bfs_invar.in_Vd_conv)
    then have "card (inedges {x}) \<le> card (E - inedges (Vvisited src C d))"
      apply (rule card_mono[rotated]) apply rule apply fact done
    finally have out: "card (E\<inverse>``{x}) \<le> card (E - inedges (Vvisited src C d))" .

    then have inr1: "card (E - inedges (Vvisited src C d)) * get_succs_list_time \<ge> card (E\<inverse>``{x}) * get_succs_list_time"
      by(simp only: mult_le_mono)

    have "card C \<ge> 1" using assms(2)
      using assms(1) nf_invar.Cge1 by blast
    then have p: "bod \<le> card C * bod" by simp
    have "card (E``{x}) * hhh  +  bod  + card (E\<inverse>``{x}) * get_succs_list_time\<le> card (E``{x}) * (hhh+bod)  + card N * bod + card C * bod + card (E\<inverse>``{x}) * get_succs_list_time"
      using p apply auto
      by (simp add: add_le_mono trans_le_add1)
    also  have  "\<dots> \<le> ?R" unfolding Te_def apply simp
      using outr1 inr1 by presburger
    finally have r: "card (E``{x}) * hhh  +  bod  + card (E\<inverse>``{x}) * get_succs_list_time \<le> ?R" .
    show "?P \<le> ?R - ?L" unfolding l
      apply(rule dual_order.trans[OF _ ] )   apply simp
      apply(rule r)
      apply(simp add: add_succs_spec_time_aux_def  comm_semiring_class.distrib distrib_left)
      done
  qed

(*
theorem pre_bfs_correct':
    assumes [simp]: "src\<in>V" "src\<noteq>dst"
    assumes [simp]: "finite V"
    shows "pre_bfs src dst \<le> SPECT (emb (bfs_spec src dst) (pre_bfs_time (card V)))"
  unfolding pre_bfs_def add_succs_spec_def
  apply(labeled_VCG rules: mop_set_pick_def mop_set_del_def  mop_set_empty_def mop_set_isempty_def)
proof casify
  case monwhile {
    case progress then show ?case by(progress\<open>simp\<close>)
    case precondition then show ?case by (auto simp: invar_init)
    case invariant {
      case cond2 {
        case the {
          case ASSERT   then show ?case by (auto simp: nf_invar.invar_C_ss_V)
          case ASSERTa  then show ?case by (auto simp: nf_invar.invar_C_ss_V)
          case ASSERTb  then show ?case by (auto simp: nf_invar.invar_C_ss_V)
          case ASSERTc  then show ?case by (auto  simp: nf_invar.invar_N_ss_Vis)
          case cond {
            case the {
              case cond2 {
                case (the ) {
                  case (time s a b ca d e x xa xb aa ba caa )  then show ?case by(auto simp: Te_pays_exit)
                }

                case func then show ?case by(auto simp: nf_invar.invar_exit')
              }
            }
      next
        case els {
          case ASSERT then show ?case by (simp add: nf_invar.invar_succ_step )
          case cond {
            case the {
              case time then show ?case by (auto intro: Te_decr_succ_step  Te_pays_succ_step)
              case func then show ?case by (auto intro!:  nf_invar'.invar_shift  nf_invar.invar_succ_step)
            }
          next
            case els {
              case time then show ?case by (auto intro: Te_decr_level_step  Te_pays_level_step)
              case func then show ?case by (auto intro: nf_invar'.invar_restore nf_invar.invar_succ_step )
            }
          }
        }
      }
    }
  }
  case postcondition {
    case cond {
      case the {
        case func then show ?case by(auto simp:  f_invar.invar_found)
        case time then show ?case by(auto simp: hlp_nat  Te_start_ub)
      next
        case els {
          case func then show ?case by(auto simp:  nf_invar.invar_not_found)
          case time then show ?case by(auto simp: hlp_nat  Te_start_ub)
        }
      }
    }
  }
qed
*)

  lemma if_splitI: "\<And>B. (b \<Longrightarrow> t \<le> A) \<Longrightarrow> (~b \<Longrightarrow> t \<le> B) \<Longrightarrow> t \<le> (if b then A else B)"
    by auto

  lemma GI: "(b \<Longrightarrow> t \<le> t') \<Longrightarrow> (b) \<Longrightarrow> Some t \<le> G b t'"
    by (auto simp: G_def)

  lemma rr: "\<And>B. A \<le> B \<Longrightarrow> a \<le> A \<Longrightarrow> (A::enat)-a \<le> B -a"
    by (simp add: helper)

  lemma r: "(a + enat b) - enat b = (a::enat)"  apply(cases a) by auto

  lemma HI: "((Es0 \<ge> Es) \<Longrightarrow> Some (t' + t + (Es0 - Es)) \<le> Qs)  \<Longrightarrow> (Es0 \<ge> Es) \<Longrightarrow> Some t' \<le> H Qs t Es0 Es"
    unfolding H_def unfolding mm3_def apply simp
    unfolding mm2_def apply simp apply(cases Qs)   apply auto
    subgoal
      using leD less_le_trans by fastforce
    subgoal for i apply(cases t) defer apply simp
      apply simp
  proof (goal_cases)
    case (1 a)
    from 1(2) have gl: "a + (Es0 - Es) = a + Es0 - Es" by auto
    thm rr[OF 1(1), where a="t + enat (Es0 - Es)"]
    have "t' = (t' + enat (a + (Es0 - Es))) - (enat (a + (Es0 - Es)))" by(simp add: r)
    also have "\<dots> \<le> i - (enat (a + (Es0 - Es)))"
      apply(rule rr)
      subgoal using 1(1) by (simp add: add.assoc)
      by simp
    finally show ?case unfolding gl .
  qed
    done

  lemma Te_decr: "nf_invar c src dst f {} N d \<Longrightarrow> Te src (False, PRED, {}, N, d) \<le> Te src (False, [src \<mapsto> src], {src}, {}, 0)"
    unfolding Te_def apply clarsimp
  proof (goal_cases)
    case 1
    with nf_invar.empty_assm have Ne: "N= {}" by blast
    from 1 have "finite (Graph.V c)"
      by simp
    have "Graph.V c = V" by auto
    from 1 have "finite (Graph.E c)"
      by simp
    moreover have "Graph.E c = E" by auto
    ultimately have fE: "finite E" by auto

    have v_e: "Vvisited src {src} 0 = {}" apply (simp add: Vvisited_def) using pre_bfs_invar.src_Vd0 by auto
    from v_e have "E - (outedges (Vvisited src {} d)) \<subseteq> E - (outedges (Vvisited src {src} 0))" by auto
    have Aout: "card (E - (outedges (Vvisited src {} d))) \<le> card (E - (outedges (Vvisited src {src} 0)))"
      apply(rule card_mono) apply(rule finite_Diff) apply fact
      apply fact done

    from v_e have "E - (inedges (Vvisited src {} d)) \<subseteq> E - (inedges (Vvisited src {src} 0))" by auto
    have Ain: "card (E - (inedges (Vvisited src {} d))) \<le> card (E - (inedges (Vvisited src {src} 0)))"
      apply(rule card_mono) apply(rule finite_Diff) apply fact
      apply fact done

      show ?case  unfolding Ne apply simp
        apply(rule order.trans[OF add_le_mono])
          apply(rule mult_le_mono1) apply fact
         apply(rule mult_le_mono1) apply fact
        by simp
  qed

  lemma (in nf_invar') domPREDV: "dom PRED \<subseteq> V"
    unfolding VIS_eq N_eq Vd_def V_def apply auto
    by (smt Graph.min_dist_is_dist SRC_IN_V V_def dist_cases mem_Collect_eq)

  lemma (in nf_invar') N_V: "N \<subseteq> V"
    unfolding   N_eq Vd_def V_def by auto

  theorem pre_bfs_correct:
    assumes [simp]: "src\<in>V" "src\<noteq>dst"
    assumes [simp]: "finite V"
    shows "pre_bfs src dst \<le> SPECT (emb (bfs_spec src dst) (pre_bfs_time (card E)))"
    unfolding pre_bfs_def add_succs_spec_def
    apply(rule T_specifies_I)

    apply(vcg' \<open>clarsimp\<close> rules: if_splitI GI HI  mop_set_pick_extract    mop_set_empty mop_set_isempty)
    apply (simp_all split: bool.splits add: Some_le_mm3_Some_conv Some_le_emb'_conv)
    apply safe

      apply ( vc_solve  simp:  domI
            Te_pays_exit

            Te_decr_level_step(1)
            Te_decr_level_step(2)

            invar_init

            nf_invar.invar_C_ss_V
            nf_invar.invar_succ_step
              nf_invar.invar_exit'
            nf_invar'.invar_shift
            nf_invar'.invar_restore
            nf_invar.finite_succ
            nf_invar.invar_N_ss_Vis)
    subgoal apply(subst (asm) Te_decr_succ_step(2)) by auto
    subgoal apply(subst (asm) Te_decr_succ_step(2)) by auto
    subgoal by (auto intro!: Te_decr_succ_step)
    subgoal by (auto intro!: Te_decr_succ_step)
    subgoal by (auto intro: Te_decr_level_step(2))
    subgoal by (auto intro: Te_decr_level_step(2))
    subgoal by (auto intro:   nf_invar'.invar_restore   nf_invar.invar_succ_step )
    subgoal by(auto intro: Te_decr_level_step)
    subgoal by (auto intro:   nf_invar'.invar_restore   nf_invar.invar_succ_step )
    subgoal by(auto intro: Te_decr_level_step)
    subgoal by (auto  simp: nf_invar_def dest: nf_invar'.N_V)
    subgoal using V_def by blast
    subgoal by (auto  simp: nf_invar_def dest: nf_invar'.domPREDV)
    subgoal by(auto dest: nf_invar.cardC)
    subgoal by(auto simp:  f_invar.invar_found)
    subgoal unfolding f_invar_def  using Te_start_ub by(auto intro!:  hlp_nat  )
    subgoal by(auto simp:  nf_invar.invar_not_found)
    subgoal unfolding nf_invar'_def nf_invar_def  using Te_start_ub by(auto intro!:  hlp_nat  )
    subgoal using Te_decr by auto
    subgoal for a b d e apply(cases a) subgoal   by auto using Te_decr by auto
    done

end

locale valid_PRED_impl = valid_PRED +
  fixes list_append_time map_lookup_time :: nat assumes [simp]: "map_lookup_time > 0"

context Graph
begin

  subsection \<open>Extraction of Result Path\<close>

    definition "extract_rpath_inv src dst PRED = (\<lambda>(v,p).
          v\<in>dom PRED
        \<and> isPath v p dst
        \<and> distinct (pathVertices v p)
        \<and> (\<forall>v'\<in>set (pathVertices v p).
            pre_bfs_invar.ndist c src v \<le> pre_bfs_invar.ndist c src v')
        \<and> pre_bfs_invar.ndist c src v + length p
          = pre_bfs_invar.ndist c src dst)"

  definition (in valid_PRED_impl) "extract_rpath_time' = ndist dst * (map_lookup_time + list_append_time)"
  definition (in -) "extract_rpath_time_aux cV v1 v2 = cV * (v1 + v2)"
  abbreviation (in valid_PRED_impl) "extract_rpath_time cV \<equiv> extract_rpath_time_aux cV map_lookup_time list_append_time"

lemma (in valid_PRED) ndist_le_V:  assumes [simp]: "finite V" and conn: "connected src dst"
  shows "ndist dst \<le> card V"
proof -
  from conn obtain p where isP: "isPath src p dst" and dist: "distinct (pathVertices src p)"
    unfolding connected_def  apply auto apply(frule isSPath_pathLE) unfolding isSimplePath_def  by blast

  have "ndist dst \<le> length p"
    unfolding min_dist_def  dist_def apply(rule Least_le) apply(rule exI[where x=p])
    using isP by simp
  also have "\<dots> \<le> length (pathVertices src p)" by(simp add: length_pathVertices_eq)
  also from dist have "\<dots> = card (set (pathVertices src p))"
    by(simp add: distinct_card)
  also have "\<dots> \<le> card V"
    apply(rule card_mono) apply simp
    using  pathVertices_edgeset[OF _ isP] by auto

  finally
  show "ndist dst \<le> card V" .
  qed

    definition (in valid_PRED_impl) "Ter  = (\<lambda>(d,_). ndist d * (map_lookup_time + list_append_time))"

    term valid_PRED_impl.Ter
    definition (in -) "extract_rpath src dst PRED map_lookup_time list_append_time V   \<equiv> do {
      (d,p) \<leftarrow> whileT
        (\<lambda>(v,p). v\<noteq>src) (\<lambda>(v,p). do {
        ASSERT (v\<in>dom PRED);
        ASSERT (v\<in>V);
        ASSERT (card (dom PRED) \<le> card V);
        u \<leftarrow> mop_map_lookup (\<lambda>_. map_lookup_time) PRED v;
        p \<leftarrow> mop_append (\<lambda>_. list_append_time) (u,v) p;
        v \<leftarrow> RETURNT u;
        RETURNT (v,p)
      }) (dst,[]);
      RETURNT p
    }"

  end

  context valid_PRED_impl begin

  thm FIN_V
  lemma domPREDV: "dom PRED \<subseteq> V"
    apply auto subgoal for x y
      apply(cases "x=src") using SRC_IN_V apply simp
      apply(frule PRED_E) apply simp unfolding V_def by auto
    done

    lemma extract_rpath_correct':
      assumes "dst\<in>dom PRED"
      shows "extract_rpath src dst PRED   map_lookup_time list_append_time V
        \<le> SPECT (emb (\<lambda>p. isSimplePath src p dst \<and> length p = ndist dst) extract_rpath_time')"
      using assms unfolding extract_rpath_def isSimplePath_def
      apply(subst whileIET_def[symmetric, where I="extract_rpath_inv src dst PRED" and E =Ter  ])
      apply simp
      apply(rule T_specifies_I)
      apply (vcg'\<open>-\<close> rules: mop_map_lookup mop_append)

      apply (auto simp: Some_le_mm3_Some_conv Some_le_emb'_conv
                          extract_rpath_time'_def extract_rpath_inv_def
                               PRED_closed[THEN domD] PRED_E PRED_dist Ter_def)
      subgoal apply(rule card_mono) by (simp_all add: domPREDV)
      subgoal using domPREDV by auto
      done

    lemma extract_rpath_correct:
      assumes "dst\<in>dom PRED"
      shows "extract_rpath  src dst PRED map_lookup_time list_append_time V
        \<le> SPECT (emb (\<lambda>p. isSimplePath src p dst \<and> length p = ndist dst) (extract_rpath_time (card V)))"
      apply(rule dual_order.trans[OF _ extract_rpath_correct'])
      apply (auto simp add: emb_le_emb extract_rpath_time_aux_def extract_rpath_time'_def intro!: ndist_le_V)
        using assms  apply auto
        using Graph.isPath_rtc Graph.isSimplePath_def connected_edgeRtc by blast
  end

locale Augmenting_Path_BFS = Graph +
  fixes  set_insert_time map_dom_member_time  get_succs_list_time map_update_time set_pick_extract_time :: nat
    and list_append_time map_lookup_time set_empty_time set_isempty_time init_state_time init_get_succs_list_time :: nat
  assumes [simp]: "map_lookup_time > 0"
  assumes [simp]: "set_pick_extract_time > 0"
begin

interpretation pre: Pre_BFS_Impl c set_insert_time map_dom_member_time
    get_succs_list_time map_update_time set_pick_extract_time set_empty_time set_isempty_time init_state_time init_get_succs_list_time
  apply standard by simp

  term Pre_BFS_Impl.pre_bfs

    definition "bfs src dst \<equiv> do {
      if src=dst then RETURNT (Some [])
      else do {
        br \<leftarrow> pre.pre_bfs src dst;
        case br of
          None \<Rightarrow> RETURNT None
        | Some (d,PRED) \<Rightarrow> do {
            p \<leftarrow> extract_rpath src dst PRED map_lookup_time list_append_time V;
            RETURNT (Some p)
          }
      }
    }"  thm pre.pre_bfs_correct

    definition bfs_time   where "bfs_time src dst = pre.pre_bfs_time  (card E)   + valid_PRED_impl.extract_rpath_time list_append_time map_lookup_time (card V)"

    lemma bfs_correct:
      assumes "src\<in>V" "finite V"
      shows "bfs src dst
        \<le> SPECT (emb (\<lambda>
          None \<Rightarrow> \<not>connected src dst
        | Some p \<Rightarrow> isShortestPath src p dst) (bfs_time src dst))"
      unfolding bfs_def
      apply(rule T_specifies_I)
      apply(vcg'\<open>simp\<close> rules: pre.pre_bfs_correct[THEN T_specifies_rev , THEN T_conseq4]
                    valid_PRED_impl.extract_rpath_correct[THEN T_specifies_rev, THEN T_conseq4])
      by (auto simp add: Some_le_mm3_Some_conv Some_le_emb'_conv Some_eq_emb'_conv
              assms bfs_time_def
              isShortestPath_min_dist_def   valid_PRED_impl_def valid_PRED_impl_axioms_def
              bfs_spec_def isSimplePath_def)

  end

  subsection \<open>Inserting inner Loop and Successor Function\<close>
  context Pre_BFS_Impl begin

  definition "foreach_body_time = set_insert_time + 10"

  term "(\<lambda>it (f,PRED',N').
        PRED' = map_mmupd PRED ((succ - it) - dom PRED) u
      \<and> N' = N \<union> ((succ - it) - dom PRED)
      \<and> f = (dst\<in>(succ - it) - dom PRED)
    )"

  definition "inner_loop dst succ u PRED N \<equiv> nfoldliIE
    (\<lambda>ti it (f,PRED',N').
        PRED' = map_mmupd PRED ((set ti) - dom PRED) u
      \<and> N' = N \<union> ((set ti) - dom PRED)
      \<and> f = (dst\<in>(set ti) - dom PRED) \<and> dom PRED \<subseteq> V
    )  (map_dom_member_time+((set_insert_time+map_update_time) + (1::nat)))
    (succ)
    (\<lambda>(f,PRED,N). \<not>f)
    (\<lambda>v (f,PRED,N). do {
      ASSERT (card (dom PRED) \<le> card V);
      ASSERT (v\<in>V);
      b \<leftarrow> mop_map_dom_member (%_. map_dom_member_time) PRED v;
      if b then RETURNT (f,PRED,N)
      else do {
        PRED \<leftarrow> mop_map_update (\<lambda>_. map_update_time) PRED v u;
        ASSERT (v\<notin>N);
        ASSERT (card N \<le> card V);
        N \<leftarrow> mop_set_insert (%_. set_insert_time) v N;
        RETURNT (v=dst,PRED,N)
      }
    })
    (False,PRED,N)"

  lemma GG: "N \<subseteq> V \<Longrightarrow> A \<subseteq> V \<Longrightarrow> finite V \<Longrightarrow> card (N \<union> (A - dom PRED)) \<le> card V"
    apply(rule card_mono) by auto

  lemma inner_loop_refine:
    (*assumes NSS: "N \<subseteq> dom PRED"*)
    assumes [simplified, simp]:
      "(dsti,dst)\<in>Id" "(succi,succ)\<in>Id" "(ui,u)\<in>Id" "(PREDi,PRED)\<in>Id" "(Ni,N)\<in>Id" "ssuc = (set succ)"
      "finite V"
      and PRED: "dom PRED \<subseteq> V" and ssuvV: "set succ \<subseteq> V" and  N: "N \<subseteq> V"
    shows  "distinct succ \<Longrightarrow> inner_loop dsti succi ui PREDi Ni
      \<le> \<Down>Id (add_succs_spec dst ssuc u PRED N)"
    unfolding inner_loop_def add_succs_spec_def apply simp
    apply(rule le_ASSERTI)
    apply(rule nfoldliIE_rule)
    subgoal using PRED by auto
       (* if I add a subgoal here vcg_split_case breaks, maybe problem with variable names? *)
       apply(rule T_specifies_I)
       apply (vcg'\<open>-\<close> rules: mop_map_dom_member T_RESTemb mop_map_update  mop_set_insert )

         apply(auto simp add: Some_le_mm3_Some_conv Some_le_emb'_conv one_enat_def)
      subgoal by (auto simp: it_step_insert_iff map_mmupd_def)
      subgoal
        by(auto simp: map_mmupd_def)
      subgoal apply(subst (asm) GG) using ssuvV N by auto
      subgoal apply(subst (asm) GG) using ssuvV N by auto
      subgoal using ssuvV by auto
      subgoal using ssuvV by auto
      subgoal apply(rule card_mono) using ssuvV  by auto
      subgoal apply(rule card_mono) using ssuvV  by auto
    subgoal by (auto split: bool.split simp add: domIff intro!: map_mmupd_update_less )
    subgoal by (auto split: bool.split  simp add: domIff )
    subgoal by (auto simp: hh_def add_succs_spec_time_aux_def distinct_card )
    done

  lemma inner_loop2_correct:
    assumes SR: "(succl,succ)\<in>\<langle>Id\<rangle>list_set_rel"
    assumes [simplified, simp]:
      "(dsti,dst)\<in>Id" "(ui, u) \<in> Id" "(PREDi, PRED) \<in> Id" "(Ni, N) \<in> Id" "finite V"
      and PRED: "dom PRED \<subseteq> V" and ssuvV: "set succl \<subseteq> V" and  N: "N \<subseteq> V"
    shows "inner_loop dsti succl ui PREDi Ni \<le> \<Down>Id (add_succs_spec dst succ u PRED N)"
    apply(rule inner_loop_refine) using SR ssuvV PRED N by (auto simp: list_set_rel_def br_def)

  type_synonym bfs_state = "bool \<times> (node \<rightharpoonup> node) \<times> node set \<times> node set \<times> nat"

    context
      fixes succ :: "node \<Rightarrow> node list nrest"
      fixes init_state :: "node \<Rightarrow> bfs_state nrest"
    begin

      definition "loopguard f C = do {
                  b \<leftarrow> mop_set_isempty (\<lambda>_. set_isempty_time) C;
                  RETURNT (f=False \<and> ~b) }"

      lemma loopguard_correct: "(f,f')\<in>Id \<Longrightarrow> (C,C')\<in>Id \<Longrightarrow> loopguard f C \<le> \<Down>Id ( SPECT [f' = False \<and> C' \<noteq> {} \<mapsto> enat set_isempty_time] )"
        unfolding loopguard_def apply simp
        apply(rule T_specifies_I)
        by (vcg'\<open>simp\<close> rules: mop_set_isempty )

      definition pre_bfs2 :: "node \<Rightarrow> node \<Rightarrow> (nat \<times> (node\<rightharpoonup>node)) option nrest"
        where "pre_bfs2 src dst \<equiv> do {
        s \<leftarrow> init_state src;
        (f,PRED,ttt,tt,d) \<leftarrow> monadic_WHILE (\<lambda>(f,PRED,C,N,d). loopguard f C)
          (\<lambda>(f,PRED,C,N,d). do {
            ASSERT (C\<noteq>{});
            ASSERT (card C\<le>card V);
            (v,C) \<leftarrow> mop_set_pick_extract (\<lambda>_. set_pick_extract_time) C;
            ASSERT (v\<in>V);
            sl \<leftarrow> succ v;
            ASSERT (finite V);
            ASSERT (dom PRED \<subseteq> V);
            ASSERT (set sl \<subseteq> V);
            ASSERT (N \<subseteq> V);
            (f,PRED,N) \<leftarrow> inner_loop dst sl v PRED N;
            if f then
              RETURNT (f,PRED,C,N,d+(1::nat))
            else do {
              ASSERT (assn1 src dst (f,PRED,C,N,d));
              b \<leftarrow> mop_set_isempty (\<lambda>_. set_isempty_time) C;
              if b then do {
                C \<leftarrow> RETURNT N;
                N \<leftarrow> mop_set_empty (\<lambda>_. set_empty_time);
                d \<leftarrow> RETURNT (d+(1::nat));
                RETURNT (f,PRED,C,N,d)
              } else RETURNT (f,PRED,C,N,d)
            }
          })
          s;
        if f then RETURNT (Some (d, PRED)) else RETURNT None
        }"

  lemma distinct_in_list_set_rel: "distinct l \<Longrightarrow> (l, set l) \<in> \<langle>Id\<rangle>list_set_rel"
      by (auto simp add: list_set_rel_def br_def Some_eq_emb'_conv)

  lemma pre_bfs2_refine:
    assumes succ_impl: "\<And>ui u. \<lbrakk>(ui,u)\<in>Id; u\<in>V\<rbrakk>
        \<Longrightarrow> succ ui \<le> \<Down> (\<langle>Id\<rangle>list_set_rel) (SPECT [E``{u} \<mapsto> enat (init_get_succs_list_time+ (card (E``{u}) + card (E\<inverse>``{u}))*get_succs_list_time )])"
      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 "pre_bfs2 src dst \<le>\<Down>Id (pre_bfs src dst)"
  proof -
    have i: "\<And>t x. SPECT (emb (\<lambda>l. distinct l \<and> set l = E `` {x}) (enat t)) \<le> \<Down> (\<langle>Id\<rangle>list_set_rel) (SPECT [E``{x} \<mapsto> enat t])"
      apply(rule SPECT_refine)
      by(simp add: Some_eq_emb'_conv list_set_rel_def br_def)

    have ii: "\<And>t x. \<Down> (\<langle>Id\<rangle>list_set_rel) (SPECT [E``{x} \<mapsto> enat t]) \<le> SPECT (emb (\<lambda>l. distinct l \<and> set l = E `` {x}) (enat t))"
      using Sup_le_iff by (auto simp: conc_fun_def le_fun_def emb'_def list_set_rel_def br_def )

    have rew: "\<And>tt x. SPECT (emb (\<lambda>l. distinct l \<and> set l = E `` {x}) (enat tt)) = \<Down> (\<langle>Id\<rangle>list_set_rel) (SPECT [E``{x} \<mapsto> enat tt])"
      apply(rule antisym) using i ii by auto

    have succ_impl': "\<And>v va. (v,va)\<in>Id \<Longrightarrow> va\<in>V \<Longrightarrow> succ v \<le> \<Down> (\<langle>nat_rel\<rangle>list_rel) (SPECT (emb (\<lambda>l. distinct l \<and> set l = E `` {va}) (enat (init_get_succs_list_time + (card (E `` {va}) + card (E\<inverse> `` {va})) * get_succs_list_time))))"
      unfolding rew apply simp apply(rule succ_impl) by auto

    show ?thesis
    unfolding pre_bfs_def pre_bfs2_def monadic_WHILEIE_def
    apply (refine_rcg init_state_impl monadic_WHILE_refine loopguard_correct inner_loop2_correct succ_impl')
                        apply refine_dref_type
    by (auto split: if_splits  simp: distinct_in_list_set_rel)

  qed

end

end \<comment> \<open>Pre_BFS_Impl\<close>

context Augmenting_Path_BFS
begin

  interpretation pre: Pre_BFS_Impl c set_insert_time map_dom_member_time  get_succs_list_time map_update_time set_pick_extract_time
    set_empty_time set_isempty_time init_state_time init_get_succs_list_time
    apply standard by simp

    definition "bfs2 succ init_state src dst \<equiv> do {
      if src=dst then
        RETURNT (Some [])
      else do {
        br \<leftarrow> pre.pre_bfs2 succ init_state src dst;
        case br of
          None \<Rightarrow> RETURNT None
        | Some (d,PRED) \<Rightarrow> do {
            p \<leftarrow> extract_rpath  src dst PRED  map_lookup_time list_append_time V;
            RETURNT (Some p)
          }
      }
    }"

end


section {* \isaheader{Iterators} *}
theory Gen_Iterator
imports "../../Refine_Monadic/Refine_Monadic" "Proper_Iterator"
begin
  text {*
    Iterators are realized by to-list functions followed by folding.
    A post-optimization step then replaces these constructions by
    real iterators. *}

  lemma param_it_to_list[param]: "(it_to_list,it_to_list) \<in>
    (Rs \<rightarrow> (Ra \<rightarrow> bool_rel) \<rightarrow>
    (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel) \<rightarrow> \<langle>Rc\<rangle>list_rel \<rightarrow> Rd) \<rightarrow> Rs \<rightarrow> Rd"
    unfolding it_to_list_def[abs_def]
    by parametricity

  definition key_rel :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) \<Rightarrow> ('k\<times>'v) \<Rightarrow> bool"
    where "key_rel R a b \<equiv> R (fst a) (fst b)"

  lemma key_rel_UNIV[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
    unfolding key_rel_def[abs_def] by auto

  subsection {* Setup for Autoref *}
  text {* Default pattern rules for @{text "it_to_sorted_list"}*}
  definition "set_to_sorted_list R S \<equiv> it_to_sorted_list R S"

context begin interpretation autoref_syn .
  lemma set_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list R S \<equiv> OP (set_to_sorted_list R) S"
    unfolding set_to_sorted_list_def[abs_def] by auto
end

  definition "map_to_sorted_list R M
    \<equiv> it_to_sorted_list (key_rel R) (map_to_set M)"
  lemma map_to_sorted_list_itype[autoref_itype]:
    "map_to_sorted_list R ::\<^sub>i \<langle>Rk,Rv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Rk,Rv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres"
    by simp

context begin interpretation autoref_syn .
  lemma map_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list (key_rel R) (map_to_set M)
      \<equiv> OP (map_to_sorted_list R) M"
    "it_to_sorted_list (\<lambda>_ _. True) (map_to_set M)
      \<equiv> OP (map_to_sorted_list (\<lambda>_ _. True)) M"
    unfolding map_to_sorted_list_def[abs_def] by auto
end

  subsection {* Set iterators *}
  (*definition "is_set_to_sorted_list_deprecated ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs \<longrightarrow>
      (RETURN (tsl s),it_to_sorted_list ordR s')\<in>\<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    *)

  definition "is_set_to_sorted_list ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs
      \<longrightarrow> ( \<exists>l'. (tsl s,l')\<in>\<langle>Rk\<rangle>list_rel
            \<and> RETURN l' \<le> it_to_sorted_list ordR s')"

  definition "is_set_to_list \<equiv> is_set_to_sorted_list (\<lambda>_ _. True)"

  lemma is_set_to_sorted_listE:
    assumes "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    obtains l' where "(tsl s,l')\<in>\<langle>Rk\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list ordR s'"
    using assms unfolding is_set_to_sorted_list_def by blast

  (* TODO: Move *)
  lemma it_to_sorted_list_weaken:
    "R\<le>R' \<Longrightarrow> it_to_sorted_list R s \<le> it_to_sorted_list R' s"
    unfolding it_to_sorted_list_def
    by (auto intro!: sorted_by_rel_weaken[where R=R])

  lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "is_set_to_list Rk Rs tsl"
    using assms
    unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    by blast

  definition "det_fold_set R c f \<sigma> result \<equiv>
    \<forall>l. distinct l \<and> sorted_by_rel R l \<longrightarrow> foldli l c f \<sigma> = result (set l)"

  lemma det_fold_setI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct l; sorted_by_rel R l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (set l)"
    shows "det_fold_set R c f \<sigma> result"
    using assms unfolding det_fold_set_def by auto

  text {* Template lemma for generic algorithm using set iterator *}
  lemma det_fold_sorted_set:
    assumes 1: "det_fold_set ordR c' f' \<sigma>' result"
    assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes SREF[param]: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list ordR s'"
      using 2 SREF
      by (rule is_set_to_sorted_listE)

    have "(foldli (tsl s) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result s'"
      using 1 IT
      unfolding det_fold_set_def it_to_sorted_list_def
      by simp
    finally show ?thesis .
  qed

  lemma det_fold_set:
    assumes "det_fold_set (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_set_to_list Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
    using assms
    unfolding  is_set_to_list_def
    by (rule det_fold_sorted_set)

  subsection {* Map iterators *}

  text {* Build relation on keys *}

  (*definition "is_map_to_sorted_list_deprecated ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow>
      (RETURN (tsl m),it_to_sorted_list (key_rel ordR) (map_to_set m'))
      \<in>\<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"*)

  definition "is_map_to_sorted_list ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow> (
      \<exists>l'. (tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<and> RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m'))"

  definition "is_map_to_list Rk Rv Rm tsl
    \<equiv> is_map_to_sorted_list (\<lambda>_ _. True) Rk Rv Rm tsl"

  lemma is_map_to_sorted_listE:
    assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    obtains l' where "(tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
    using assms unfolding is_map_to_sorted_list_def by blast

  lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
    shows "is_map_to_list Rk Rv Rm tsl"
    using assms
    unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    unfolding key_rel_def[abs_def]
    by blast

  definition "det_fold_map R c f \<sigma> result \<equiv>
    \<forall>l. distinct (map fst l) \<and> sorted_by_rel (key_rel R) l
      \<longrightarrow> foldli l c f \<sigma> = result (map_of l)"

  lemma det_fold_mapI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct (map fst l); sorted_by_rel (key_rel R) l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    shows "det_fold_map R c f \<sigma> result"
    using assms unfolding det_fold_map_def by auto

  lemma det_fold_map_aux:
    assumes 1: "\<lbrakk>distinct (map fst l); sorted_by_rel (key_rel R) l \<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    assumes 2: "RETURN l \<le> it_to_sorted_list (key_rel R) (map_to_set m)"
    shows "foldli l c f \<sigma> = result m"
  proof -
    from 2 have "distinct l" and "set l = map_to_set m"
      and SORTED: "sorted_by_rel (key_rel R) l"
      unfolding it_to_sorted_list_def by simp_all
    hence "\<forall>(k,v)\<in>set l. \<forall>(k',v')\<in>set l. k=k' \<longrightarrow> v=v'"
      apply simp
      unfolding map_to_set_def
      apply auto
      done
    with `distinct l` have DF: "distinct (map fst l)"
      apply (induct l)
      apply simp
      apply force
      done
    with `set l = map_to_set m` have [simp]: "m = map_of l"
      by (metis map_of_map_to_set)

    from 1[OF DF SORTED] show ?thesis by simp
  qed

  text {* Template lemma for generic algorithm using map iterator *}
  lemma det_fold_sorted_map:
    assumes 1: "det_fold_map ordR c' f' \<sigma>' result"
    assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes MREF[param]: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl m,tsl') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
      using 2 MREF by (rule is_map_to_sorted_listE)

    have "(foldli (tsl m) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result m'"
      using det_fold_map_aux[of tsl' ordR c' f' \<sigma>' result] 1 IT
      unfolding det_fold_map_def
      by clarsimp
    finally show ?thesis .
  qed

  lemma det_fold_map:
    assumes "det_fold_map (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_map_to_list Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
    using assms
    unfolding is_map_to_list_def
    by (rule det_fold_sorted_map)

lemma set_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), set_to_sorted_list R)
    \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>Rk\<rangle>list_rel"
      and R2: "RETURN l' \<le> set_to_sorted_list R s'"
    unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>Rk\<rangle>list_rel) (RETURN l')"
    by (rule RETURN_refine) fact
  also note R2
  finally show "RETURN (tsl s) \<le> \<Down> (\<langle>Rk\<rangle>list_rel) (set_to_sorted_list R s')" .
qed

lemma map_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list R)
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk,Rv\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and R2: "RETURN l' \<le> map_to_sorted_list R s'"
    unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (RETURN l')"
    apply (rule RETURN_refine)
    by fact
  also note R2
  finally show
    "RETURN (tsl s) \<le> \<Down> (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (map_to_sorted_list R s')" .
qed

lemma map_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list (\<lambda>_ _. True))
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
  using assms(2-) unfolding is_map_to_list_def
  by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])

(*lemma dres_it_FOREACH_it_simp[iterator_simps]:
  "dres_it_FOREACH (\<lambda>s. dRETURN (i s)) s c f \<sigma>
    = foldli (i s) (case_dres False False c) (\<lambda>x s. s \<bind> f x) (dRETURN \<sigma>)"
  unfolding dres_it_FOREACH_def
  by simp
*)

text {*
  TODO/FIXME:
    * Integrate mono-prover properly into solver-infrastructure,
        i.e. tag a mono-goal.
    * Tag iterators, such that, for the mono-prover, we can just convert
        a proper iterator back to its foldli-equivalent!
*}
lemma proper_it_mono_dres_pair:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. f k v x \<le> f' k v x"
  shows "
    it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>" (is "?a \<le> ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. case_prod f kv x \<le> case_prod f' kv x"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres_pair_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. flat_ge (f k v x) (f' k v x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>)"
      (is "flat_ge ?a ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. flat_ge (case_prod f kv x) (case_prod f' kv x)"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres_flat[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres[OF A])
  done

lemma proper_it_mono_dres_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres_flat[OF A])
  done

lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it'
  \<Longrightarrow> proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
  apply (rule proper_it'I)
  apply (simp add: comp_def)
  apply (rule icf_proper_iteratorI)
  apply (erule proper_it'D)
  done

lemma proper_it_mono_dres_dom:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le>
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"

  apply (rule proper_it_mono_dres)
  apply (rule icf_proper_iteratorI)
  by fact+

lemma proper_it_mono_dres_dom_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "flat_ge
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_it_mono_dres_flat)
  apply (rule icf_proper_iteratorI)
  by fact+

(* TODO/FIXME: Hack! Mono-prover should be able to find proper-iterators itself
*)
lemmas proper_it_monos =
  proper_it_mono_dres_pair proper_it_mono_dres_pair_flat
  proper_it_mono_dres proper_it_mono_dres_flat
  proper_it_mono_dres_dom proper_it_mono_dres_dom_flat

(* TODO: Conceptually, this leads to some kind of bundles:
  Each bundle has a list of processors, that are invoked for every registered
  theorem. *)

attribute_setup "proper_it" = {*
  Scan.succeed (Thm.declaration_attribute (fn thm => fn context =>
    let
      val mono_thms = map_filter (try (curry op RS thm)) @{thms proper_it_monos}
      (*val mono_thms = map (fn mt => thm RS mt) @{thms proper_it_monos}*)
      val context = context
        |> Icf_Proper_Iterator.add_thm thm
        |> fold Refine_Mono_Prover.add_mono_thm mono_thms
    in
      context
    end
  ))
  *}
  "Proper iterator declaration"

end


header {* \isaheader{Iterator by get and size } *}
theory Idx_Iterator
imports
  SetIterator
  "../../Automatic_Refinement/Automatic_Refinement"
begin

fun idx_iteratei_aux
  :: "('s \<Rightarrow> nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
where
  "idx_iteratei_aux get sz i l c f \<sigma> = (
    if i=0 \<or> \<not> c \<sigma> then \<sigma>
    else idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)
  )"

declare idx_iteratei_aux.simps[simp del]

lemma idx_iteratei_aux_simps[simp]:
  "i=0 \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = \<sigma>"
  "\<not>c \<sigma> \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = \<sigma>"
  "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_iteratei_aux get sz i l c f \<sigma> = idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)"
  apply -
  apply (subst idx_iteratei_aux.simps, simp)+
  done

definition "idx_iteratei get sz l c f \<sigma> == idx_iteratei_aux get (sz l) (sz l) l c f \<sigma>"

lemma idx_iteratei_eq_foldli:
  assumes sz: "(sz, length) \<in> arel \<rightarrow> nat_rel"
  assumes get: "(get, op!) \<in> arel \<rightarrow> nat_rel \<rightarrow> Id"
  assumes "(s,s') \<in> arel"
  shows "(idx_iteratei get sz s, foldli s') \<in> Id"
proof-
  have size_correct: "\<And>s s'. (s,s') \<in> arel \<Longrightarrow> sz s = length s'"
      using sz[param_fo] by simp
  have get_correct: "\<And>s s' n. (s,s') \<in> arel \<Longrightarrow> get s n = s' ! n"
      using get[param_fo] by simp
  {
    fix n l
    assume A: "Suc n \<le> length l"
    hence B: "length l - Suc n < length l" by simp
    from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
    from Cons_nth_drop_Suc[OF B, simplified] have
      "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
      by simp
  } note drop_aux=this

  {
    fix s s' c f \<sigma> i
    assume "(s,s') \<in> arel" "i\<le>sz s"
    hence "idx_iteratei_aux get (sz s) i s c f \<sigma> = foldli (drop (sz s - i) s') c f \<sigma>"
    proof (induct i arbitrary: \<sigma>)
      case 0 with size_correct[of s] show ?case by simp
    next
      case (Suc n)
      note S = Suc.prems(1)
      show ?case proof (cases "c \<sigma>")
        case False thus ?thesis by simp
      next
        case True[simp, intro!]
        show ?thesis using Suc
            by (simp add: size_correct[OF S] get_correct[OF S] drop_aux)
      qed
    qed
  } note aux=this

  show ?thesis
    unfolding idx_iteratei_def[abs_def]
    by (simp, intro ext, simp add: aux[OF `(s,s') \<in> arel`])
qed

text {*  Misc. *}

lemma idx_iteratei_aux_nth_conv_foldli_drop:
  fixes xs :: "'b list"
  assumes "i \<le> length xs"
  shows "idx_iteratei_aux op ! (length xs) i xs c f \<sigma> = foldli (drop (length xs - i) xs) c f \<sigma>"
using assms
proof(induct get\<equiv>"op ! :: 'b list \<Rightarrow> nat \<Rightarrow> 'b" sz\<equiv>"length xs" i xs c f \<sigma> rule: idx_iteratei_aux.induct)
  case (1 i l c f \<sigma>)
  show ?case
  proof(cases "i = 0 \<or> \<not> c \<sigma>")
    case True thus ?thesis
      by(subst idx_iteratei_aux.simps)(auto)
  next
    case False
    hence i: "i > 0" and c: "c \<sigma>" by auto
    hence "idx_iteratei_aux op ! (length l) i l c f \<sigma> = idx_iteratei_aux op ! (length l) (i - 1) l c f (f (l ! (length l - i)) \<sigma>)"
      by(subst idx_iteratei_aux.simps) simp
    also have "\<dots> = foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) \<sigma>)"
      using `i \<le> length l` i c by -(rule 1, auto)
    also from `i \<le> length l` i
    have "drop (length l - i) l = (l ! (length l - i)) # drop (length l - (i - 1)) l"
      apply (subst Cons_nth_drop_Suc[symmetric])
      apply simp_all
      done
    hence "foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) \<sigma>) = foldli (drop (length l - i) l) c f \<sigma>"
      using c by simp
    finally show ?thesis .
  qed
qed

lemma idx_iteratei_nth_length_conv_foldli: "idx_iteratei nth length = foldli"
by(rule ext)+(simp add: idx_iteratei_def idx_iteratei_aux_nth_conv_foldli_drop)
end