(*  Title:      HOL/HOLCF/Bifinite.thy
    Author:     Brian Huffman
*)

section {* Profinite and bifinite cpos *}

theory Bifinite
imports Map_Functions "~~/src/HOL/Library/Countable"
begin

default_sort cpo

subsection {* Chains of finite deflations *}

locale approx_chain =
  fixes approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a"
  assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
  assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
  assumes finite_deflation_approx [simp]: "\<And>i. finite_deflation (approx i)"
begin

lemma deflation_approx: "deflation (approx i)"
using finite_deflation_approx by (rule finite_deflation_imp_deflation)

lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
using deflation_approx by (rule deflation.idem)

lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
using deflation_approx by (rule deflation.below)

lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
apply (rule finite_deflation.finite_range)
apply (rule finite_deflation_approx)
done

lemma compact_approx [simp]: "compact (approx n\<cdot>x)"
apply (rule finite_deflation.compact)
apply (rule finite_deflation_approx)
done

lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
by (rule admD2, simp_all)

end

subsection {* Omega-profinite and bifinite domains *}

class bifinite = pcpo +
  assumes bifinite: "\<exists>(a::nat \<Rightarrow> 'a \<rightarrow> 'a). approx_chain a"

class profinite = cpo +
  assumes profinite: "\<exists>(a::nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>). approx_chain a"

subsection {* Building approx chains *}

lemma approx_chain_iso:
  assumes a: "approx_chain a"
  assumes [simp]: "\<And>x. f\<cdot>(g\<cdot>x) = x"
  assumes [simp]: "\<And>y. g\<cdot>(f\<cdot>y) = y"
  shows "approx_chain (\<lambda>i. f oo a i oo g)"
proof -
  have 1: "f oo g = ID" by (simp add: cfun_eqI)
  have 2: "ep_pair f g" by (simp add: ep_pair_def)
  from 1 2 show ?thesis
    using a unfolding approx_chain_def
    by (simp add: lub_APP ep_pair.finite_deflation_e_d_p)
qed

lemma approx_chain_u_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. u_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP u_map_ID finite_deflation_u_map)

lemma approx_chain_sfun_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. sfun_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP sfun_map_ID finite_deflation_sfun_map)

lemma approx_chain_sprod_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. sprod_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP sprod_map_ID finite_deflation_sprod_map)

lemma approx_chain_ssum_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. ssum_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP ssum_map_ID finite_deflation_ssum_map)

lemma approx_chain_cfun_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. cfun_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP cfun_map_ID finite_deflation_cfun_map)

lemma approx_chain_prod_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. prod_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP prod_map_ID finite_deflation_prod_map)

text {* Approx chains for countable discrete types. *}

definition discr_approx :: "nat \<Rightarrow> 'a::countable discr u \<rightarrow> 'a discr u"
  where "discr_approx = (\<lambda>i. \<Lambda>(up\<cdot>x). if to_nat (undiscr x) < i then up\<cdot>x else \<bottom>)"

lemma chain_discr_approx [simp]: "chain discr_approx"
unfolding discr_approx_def
by (rule chainI, simp add: monofun_cfun monofun_LAM)

lemma lub_discr_approx [simp]: "(\<Squnion>i. discr_approx i) = ID"
apply (rule cfun_eqI)
apply (simp add: contlub_cfun_fun)
apply (simp add: discr_approx_def)
apply (case_tac x, simp)
apply (rule lub_eqI)
apply (rule is_lubI)
apply (rule ub_rangeI, simp)
apply (drule ub_rangeD)
apply (erule rev_below_trans)
apply simp
apply (rule lessI)
done

lemma inj_on_undiscr [simp]: "inj_on undiscr A"
using Discr_undiscr by (rule inj_on_inverseI)

lemma finite_deflation_discr_approx: "finite_deflation (discr_approx i)"
proof
  fix x :: "'a discr u"
  show "discr_approx i\<cdot>x \<sqsubseteq> x"
    unfolding discr_approx_def
    by (cases x, simp, simp)
  show "discr_approx i\<cdot>(discr_approx i\<cdot>x) = discr_approx i\<cdot>x"
    unfolding discr_approx_def
    by (cases x, simp, simp)
  show "finite {x::'a discr u. discr_approx i\<cdot>x = x}"
  proof (rule finite_subset)
    let ?S = "insert (\<bottom>::'a discr u) ((\<lambda>x. up\<cdot>x) ` undiscr -` to_nat -` {..<i})"
    show "{x::'a discr u. discr_approx i\<cdot>x = x} \<subseteq> ?S"
      unfolding discr_approx_def
      by (rule subsetI, case_tac x, simp, simp split: split_if_asm)
    show "finite ?S"
      by (simp add: finite_vimageI)
  qed
qed

lemma discr_approx: "approx_chain discr_approx"
using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
by (rule approx_chain.intro)

subsection {* Class instance proofs *}

instance bifinite \<subseteq> profinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_u_map)
qed

instance u :: (profinite) bifinite
  by default (rule profinite)

text {*
  Types @{typ "'a \<rightarrow> 'b"} and @{typ "'a u \<rightarrow>! 'b"} are isomorphic.
*}

definition "encode_cfun = (\<Lambda> f. sfun_abs\<cdot>(fup\<cdot>f))"

definition "decode_cfun = (\<Lambda> g x. sfun_rep\<cdot>g\<cdot>(up\<cdot>x))"

lemma decode_encode_cfun [simp]: "decode_cfun\<cdot>(encode_cfun\<cdot>x) = x"
unfolding encode_cfun_def decode_cfun_def
by (simp add: eta_cfun)

lemma encode_decode_cfun [simp]: "encode_cfun\<cdot>(decode_cfun\<cdot>y) = y"
unfolding encode_cfun_def decode_cfun_def
apply (simp add: sfun_eq_iff strictify_cancel)
apply (rule cfun_eqI, case_tac x, simp_all)
done

instance cfun :: (profinite, bifinite) bifinite
proof
  obtain a :: "nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  obtain b :: "nat \<Rightarrow> 'b \<rightarrow> 'b" where b: "approx_chain b"
    using bifinite ..
  have "approx_chain (\<lambda>i. decode_cfun oo sfun_map\<cdot>(a i)\<cdot>(b i) oo encode_cfun)"
    using a b by (simp add: approx_chain_iso approx_chain_sfun_map)
  thus "\<exists>(a::nat \<Rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)). approx_chain a"
    by - (rule exI)
qed

text {*
  Types @{typ "('a * 'b) u"} and @{typ "'a u \<otimes> 'b u"} are isomorphic.
*}

definition "encode_prod_u = (\<Lambda>(up\<cdot>(x, y)). (:up\<cdot>x, up\<cdot>y:))"

definition "decode_prod_u = (\<Lambda>(:up\<cdot>x, up\<cdot>y:). up\<cdot>(x, y))"

lemma decode_encode_prod_u [simp]: "decode_prod_u\<cdot>(encode_prod_u\<cdot>x) = x"
unfolding encode_prod_u_def decode_prod_u_def
by (case_tac x, simp, rename_tac y, case_tac y, simp)

lemma encode_decode_prod_u [simp]: "encode_prod_u\<cdot>(decode_prod_u\<cdot>y) = y"
unfolding encode_prod_u_def decode_prod_u_def
apply (case_tac y, simp, rename_tac a b)
apply (case_tac a, simp, case_tac b, simp, simp)
done

instance prod :: (profinite, profinite) profinite
proof
  obtain a :: "nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  obtain b :: "nat \<Rightarrow> 'b\<^sub>\<bottom> \<rightarrow> 'b\<^sub>\<bottom>" where b: "approx_chain b"
    using profinite ..
  have "approx_chain (\<lambda>i. decode_prod_u oo sprod_map\<cdot>(a i)\<cdot>(b i) oo encode_prod_u)"
    using a b by (simp add: approx_chain_iso approx_chain_sprod_map)
  thus "\<exists>(a::nat \<Rightarrow> ('a \<times> 'b)\<^sub>\<bottom> \<rightarrow> ('a \<times> 'b)\<^sub>\<bottom>). approx_chain a"
    by - (rule exI)
qed

instance prod :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<times> 'b) \<rightarrow> ('a \<times> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_prod_map)
qed

instance sfun :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<rightarrow>! 'b) \<rightarrow> ('a \<rightarrow>! 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_sfun_map)
qed

instance sprod :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<otimes> 'b) \<rightarrow> ('a \<otimes> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_sprod_map)
qed

instance ssum :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<oplus> 'b) \<rightarrow> ('a \<oplus> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_ssum_map)
qed

lemma approx_chain_unit: "approx_chain (\<bottom> :: nat \<Rightarrow> unit \<rightarrow> unit)"
by (simp add: approx_chain_def cfun_eq_iff finite_deflation_bottom)

instance unit :: bifinite
  by default (fast intro!: approx_chain_unit)

instance discr :: (countable) profinite
  by default (fast intro!: discr_approx)

instance lift :: (countable) bifinite
proof
  note [simp] = cont_Abs_lift cont_Rep_lift Rep_lift_inverse Abs_lift_inverse
  obtain a :: "nat \<Rightarrow> ('a discr)\<^sub>\<bottom> \<rightarrow> ('a discr)\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  hence "approx_chain (\<lambda>i. (\<Lambda> y. Abs_lift y) oo a i oo (\<Lambda> x. Rep_lift x))"
    by (rule approx_chain_iso) simp_all
  thus "\<exists>(a::nat \<Rightarrow> 'a lift \<rightarrow> 'a lift). approx_chain a"
    by - (rule exI)
qed

end


theory Univ_RCF_Example imports "RCF_Decision_Proc"
begin

(*univ_rcf 1.5s; univ_rcf_cert 0.0s*)
lemma example_1:
    "\<forall>x::real. \<not>(x>=-9 \<and> x<10 \<and> x^4>0) \<or> x^12>0"
  by univ_rcf

(*univ_rcf 1.5s; univ_rcf_cert 0.1s*)
lemma example_2:
    "\<forall>x::real. \<not>((x-2)^2 * (-x+4)>0 \<and> x^2*(x-3)^2\<ge>0 \<and> x-1 \<ge> 0 \<and> - ((x - 3) ^ 2)+1>0) \<or> (-(x-11/12))^3*(x-41/10)^3\<ge>0 "
  by (univ_rcf_cert "[ALG [:0, 1:] (- 0, - 0) (- 0, - 0), ALG [:- 11, 12:] (7, - 3) (15, - 4),
                       ALG [:- 1, 1:] (1, - 0) (1, - 0), ALG [:- 2, 1:] (1, 1) (1, 1),
                       ALG [:- 3, 1:] (3, - 0) (3, - 0), ALG [:- 4, 1:] (1, 2) (1, 2),
                       ALG [:- 41, 10:] (65, - 4) (33, - 3)]")

(*univ_rcf 1.5s; univ_rcf_cert 0.0s*)
lemma example_3:
"\<exists>x::real.
      x^5 - x - 1 = 0
      \<and>
      x^12 + 425/23*x^11 - 228/23*x^10 - 2*x^8
      - 896/23*x^7 - 394/23*x^6 + 456/23*x^5 + x^4
      + 471/23*x^3 + 645/23*x^2 - 31/23*x - 228/23= 0
      \<and> x^3 + 22*x^2 -31 >=0
      \<and> x^22 -234/567*x^20 -419*x^10+ 1948>0"
  by (univ_rcf_cert "[ALG [:- 1, - 1, 0, 0, 0, 1:] (597, - 9) (299, - 8)]")

(*univ_rcf 1.6s; univ_rcf_cert 0.1*)
lemma example_4:"
\<forall>(x::real). x > 0 | -((61*x)/9) + (5*x^2)/9 + (20*x^3)/9 > -4 | 1 <= x | x <= 0 |
  -((19*x)/9) + (10*x^2)/9 <= -1 | -((13*x)/9) + (31*x^2)/45 + x^3/18 <=
   -(7/10) | -((61*x)/9) + (5*x^2)/9 + (20*x^3)/9 <= -4
"
  by (univ_rcf_cert "[ALG [:- 63, 67, 5:] (- 915, - 6) (- 457, - 5),
                       ALG [:- 36, 25, 20:] (- 17, - 3) (- 67, - 5),
                       ALG [:0, 1:] (- 0, - 0) (- 0, - 0),
                       ALG [:- 36, 25, 20:] (1751, - 11) (7005, - 13),
                       ALG [:- 63, 67, 5:] (7227, - 13) (1807, - 11),
                       ALG [:- 9, 10:] (57, - 6) (29, - 5), ALG [:- 1, 1:] (1, - 0) (1, - 0)]")

(*univ_rcf 1.7s; univ_rcf_cert 0.15*)
lemma example_5:"
\<forall>(x::real). -((5*x)/6) - (10*x^2)/3 - x^3/3 > 0 | (5*x)/6 + (10*x^2)/3 + x^3/3 > 0 |
  1 <= x | x <= 0 | -((19*x)/9) + (10*x^2)/9 <= -1 |
  -((13*x)/9) + (31*x^2)/45 + x^3/18 <= -(7/10) |
  -((101*x)/30) - (64*x^2)/15 + (14*x^3)/15 <= -(11/5) |
  -((61*x)/9) + (5*x^2)/9 + (20*x^3)/9 <= -4
"
  by (univ_rcf_cert "[ALG [:- 63, 67, 5:] (- 915, - 6) (- 457, - 5),
  ALG [:5, 20, 2:] (- 39, - 2) (- 623, - 6),
  ALG [:- 36, 25, 20:] (- 539, - 8) (- 269, - 7),
                       ALG [:66, - 101, - 128, 28:] (- 535, - 9) (- 267, - 8),
                       ALG [:5, 20, 2:] (- 263, - 10) (- 525, - 11),
                       ALG [:0, 1:] (- 0, - 0) (- 0, - 0),
                       ALG [:66, - 101, - 128, 28:] (223, - 9) (893, - 11),
                       ALG [:- 36, 25, 20:] (1751, - 11) (7005, - 13),
                       ALG [:- 63, 67, 5:] (7227, - 13) (1807, - 11),
                       ALG [:- 9, 10:] (57, - 6) (29, - 5), ALG [:- 1, 1:] (1, - 0) (1, - 0),
                       ALG [:66, - 101, - 128, 28:] (663, - 7) (83, - 4)]")

(*univ_rcf 1.7s; univ_rcf_cert 0.4*)
lemma example_6:"\<exists>x::real. -((51*x)/10) - (267*x^2)/2 - (5409*x^3)/10 - (4329*x^4)/5 - (2052*x^5)/5 -
    70*x^6 > -(7/10) & -((10327*x)/270) - (71681*x^2)/270 -
    (135853*x^3)/810 - (57328*x^4)/135 + (77743*x^5)/135 +
    (115774*x^6)/405 + (175*x^7)/18 + (49*x^8)/3 + (49*x^9)/162 >
   -(721/90) & -((2981*x)/90) - (251*x^2)/6 - (24217*x^3)/270 +
    (2698*x^4)/135 + (18964*x^5)/135 - (595*x^6)/54 + (280*x^7)/27 +
    (7*x^8)/27 > -(206/45) & -((799*x)/90) + (169*x^2)/18 -
    (7933*x^3)/270 + (2672*x^4)/135 + (329*x^5)/90 + (112*x^6)/27 +
    (7*x^7)/54 > -(103/90) & -((781*x)/90) - (701*x^2)/6 -
    (12217*x^3)/270 + (11323*x^4)/135 + (7264*x^5)/135 + (935*x^6)/54 +
    (280*x^7)/27 + (7*x^8)/27 > -(77/15) &
  -((361*x)/30) - (811*x^2)/30 + (307*x^3)/45 + (2353*x^4)/90 -
    (17*x^5)/6 + (52*x^6)/9 + (2*x^7)/9 > -(44/15) &
  -((33*x)/10) - (2*x^2)/15 + (41*x^3)/90 + (2*x^4)/15 + 2*x^5 + x^6/9 >
   -(11/15) & -((1339*x)/405) - (70225*x^2)/324 - (11549*x^3)/270 +
    (65378*x^4)/405 + (23483*x^5)/810 + (1109*x^6)/27 + (1540*x^7)/81 +
    (49*x^8)/162 > -(721/60) & -((10741*x)/540) - (2263*x^2)/45 +
    (5191*x^3)/180 + (7753*x^4)/270 - (52*x^5)/9 + (203*x^6)/18 +
    (7*x^7)/27 > -(103/15) & -((1481*x)/90) - (811*x^2)/180 +
    (2113*x^3)/90 - (493*x^4)/36 + (59*x^5)/9 + (2*x^6)/9 > -(22/5) &
  -((913*x)/180) + (563*x^2)/90 - (257*x^3)/60 + (17*x^4)/9 + x^5/9 >
   -(11/10) & -((91*x)/18) + (10*x^2)/3 - (5*x^3)/2 + (20*x^4)/9 > -2 &
  -((2*x)/9) - (25*x^2)/18 + (10*x^3)/9 > -(1/2) &
  -((61*x)/9) + (5*x^2)/9 + (20*x^3)/9 > -4 & 1 > x & x > 0 &
  -((19*x)/9) + (10*x^2)/9 > -1 & -((13*x)/9) + (31*x^2)/45 + x^3/18 >
   -(7/10) & -((253*x)/90) - (53*x^2)/30 + (34*x^3)/15 + x^4/9 >
   -(11/5) & -((97*x)/90) - (2051*x^2)/90 + (86*x^3)/15 + (82*x^4)/9 +
    (2*x^5)/9 > -(44/5) & -((93307*x)/1620) - (298609*x^2)/810 +
    (30583*x^3)/270 + (264373*x^4)/810 - (289811*x^5)/1620 +
    (3113*x^6)/27 + (931*x^7)/81 + (8*x^8)/81 > -(193/5) &
  -((4741*x)/540) - (9151*x^2)/90 + (6397*x^3)/60 - (2686*x^4)/135 +
    (28*x^5)/9 + (38*x^6)/3 + (7*x^7)/27 > -(77/10)
"
  by (univ_rcf_cert "[ALG [:- 1, 32:] (1, - 5) (1, - 5)]")

(*univ_rcf 4.2s; univ_rcf_cert 2.7
*)
lemma example_7:"
\<forall>x::real. x < -1 | 0 > x | (41613*x)/2 + 26169*x^2 + (64405*x^3)/4 + 4983*x^4 +
    (7083*x^5)/10 + (1207*x^6)/35 + x^7/8 > -6435 |
  11821609800*x + 22461058620*x^2 + 35*x^12 <=
   4171407240*x^3 + 45938678170*x^4 + 54212099480*x^5 + 31842714428*x^6 +
    10317027768*x^7 + 1758662439*x^8 + 144537452*x^9 + 5263834*x^10 +
    46204*x^11 | x <= 0 | 9609600*x + 45805760*x^2 + 92372280*x^3 +
    102560612*x^4 + 68338600*x^5 + 27930066*x^6 + 6857016*x^7 +
    938908*x^8 + 58568*x^9 + 753*x^10 <= 0 |
  788107320*x + 1101329460*x^2 + 10*x^11 <=
   782617220*x^3 + 2625491260*x^4 + 2362290448*x^5 + 1063536663*x^6 +
    240283734*x^7 + 24397102*x^8 + 1061504*x^9 + 9179*x^10 |
  90935460*x + 81290790*x^2 + 5*x^10 <= 125595120*x^3 + 237512625*x^4 +
    161529144*x^5 + 51834563*x^6 + 6846880*x^7 + 356071*x^8 + 2828*x^9 |
  640640*x + 2735040*x^2 + 4837448*x^3 + 4581220*x^4 + 2505504*x^5 +
    794964*x^6 + 138652*x^7 + 11237*x^8 + 207*x^9 <= 0 |
  5*x^8 <= 73920*x + 238560*x^2 + 303324*x^3 + 192458*x^4 + 63520*x^5 +
    10261*x^6 + 608*x^7 | 73920*x + 278880*x^2 + 424284*x^3 +
    332962*x^4 + 142928*x^5 + 32711*x^6 + 3514*x^7 + 98*x^8 <= 0 | x <= -1
"
  by univ_rcf

end


section \<open>Simple Games\<close>

theory Simple_Game
imports
  Main
begin

text \<open>Simple games are games where player0 wins all infinite plays.\<close>
locale simple_game =
fixes
  game_move :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<longmapsto>\<heartsuit> _" [70, 70] 80) and
  player0_position :: \<open>'s \<Rightarrow> bool\<close> and
  initial :: 's
begin

definition player1_position :: \<open>'s \<Rightarrow> bool\<close>
  where \<open>player1_position s \<equiv> \<not> player0_position s\<close>

\<comment>\<open>plays (to be precise: play p refixes) are lists. we model them
  with the most recent move at the beginning. (for our purpose it's enough to consider finite plays)\<close>
type_synonym ('s2) play = \<open>'s2 list\<close>
type_synonym ('s2) strategy = \<open>'s2 play \<Rightarrow> 's2\<close>

inductive_set plays :: \<open>'s play set\<close> where
  \<open>[initial] \<in> plays\<close> |
  \<open>p#play \<in> plays \<Longrightarrow> p \<longmapsto>\<heartsuit> p' \<Longrightarrow> p'#p#play \<in> plays\<close>

\<comment>\<open>plays for a given player 0 strategy\<close>
inductive_set plays_for_strategy :: \<open>'s strategy \<Rightarrow> 's play set\<close> for f where
  init: \<open>[initial] \<in> plays_for_strategy f\<close> |
  p0move: \<open>n0#play \<in> plays_for_strategy f \<Longrightarrow> player0_position n0 \<Longrightarrow> n0 \<longmapsto>\<heartsuit> f (n0#play)
    \<Longrightarrow> (f (n0#play))#n0#play \<in> plays_for_strategy f\<close> |
  p1move: \<open>n1#play \<in> plays_for_strategy f \<Longrightarrow> player1_position n1 \<Longrightarrow> n1 \<longmapsto>\<heartsuit> n1'
    \<Longrightarrow> n1'#n1#play \<in> plays_for_strategy f\<close>

lemma strategy_step:
  assumes
    \<open>n0 # n1 # rest \<in> plays_for_strategy f\<close>
    \<open>player0_position n1\<close>
  shows
    \<open>f (n1 # rest) = n0\<close>
  using assms
  by (induct rule: plays_for_strategy.cases, auto simp add: simple_game.player1_position_def)

definition positional_strategy :: \<open>'s strategy \<Rightarrow> bool\<close> where
  \<open>positional_strategy f \<equiv> \<forall>r1 r2 n. f (n # r1) = f (n # r2)\<close>

text \<open>a strategy is sound if it only decides on enabled transitions.\<close>
definition sound_strategy :: \<open>'s strategy \<Rightarrow> bool\<close> where
  \<open>sound_strategy f \<equiv>
    \<forall> n0 play . n0#play \<in> plays_for_strategy f \<and> player0_position n0 \<longrightarrow> n0 \<longmapsto>\<heartsuit> f (n0#play)\<close>

lemma strategy_plays_subset:
  assumes \<open>play \<in> plays_for_strategy f\<close>
  shows \<open>play \<in> plays\<close>
  using assms by (induct rule: plays_for_strategy.induct, auto simp add: plays.intros)

lemma no_empty_plays:
  assumes \<open>[] \<in> plays\<close>
  shows \<open>False\<close>
  using assms plays.cases by blast

text \<open>player1 wins a play if the play has reached a deadlock where it's player0's turn\<close>

definition player1_wins :: \<open>'s play \<Rightarrow> bool\<close> where
  \<open>player1_wins play \<equiv> player0_position (hd play) \<and> (\<nexists> p' . (hd play) \<longmapsto>\<heartsuit> p')\<close>

definition player0_winning_strategy :: \<open>'s strategy \<Rightarrow> bool\<close> where
  \<open>player0_winning_strategy f \<equiv> (\<forall> play \<in> plays_for_strategy f . \<not> player1_wins play)\<close>

end

end


(*  Title:       Iterators over Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section \<open>\isaheader{Iterators over Finite Sets}\<close>
theory SetIterator
imports
  Automatic_Refinement.Misc
  Automatic_Refinement.Foldi
  (*"../../Refine_Monadic/Refine_Monadic"*)
begin

text \<open>When reasoning about finite sets, it is often handy to be able to iterate over the elements
  of the set. If the finite set is represented by a list, the @{term fold} operation can be used.
  For general finite sets, the order of elements is not fixed though. Therefore, nondeterministic
  iterators are introduced in this theory.\<close>

subsection \<open>General Iterators\<close>

type_synonym ('x,'\<sigma>) set_iterator = "('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('x\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"

locale set_iterator_genord =
  fixes iti::"('x,'\<sigma>) set_iterator"
    and S0::"'x set"
    and R::"'x \<Rightarrow> 'x \<Rightarrow> bool"
  assumes foldli_transform:
    "\<exists>l0. distinct l0 \<and> S0 = set l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0"
begin
  text \<open>Let's prove some trivial lemmata to show that the formalisation agrees with
          the view of iterators described above.\<close>
  lemma set_iterator_weaken_R :
    "(\<And>x y. \<lbrakk>x \<in> S0; y \<in> S0; R x y\<rbrakk> \<Longrightarrow> R' x y) \<Longrightarrow>
             set_iterator_genord iti S0 R'"
    by (metis set_iterator_genord.intro foldli_transform sorted_wrt_mono_rel)

  lemma finite_S0 :
    shows "finite S0"
    by (metis finite_set foldli_transform)

  lemma iti_stop_rule_cond :
    assumes not_c: "\<not>(c \<sigma>)"
    shows "iti c f \<sigma> = \<sigma>"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "iti c = foldli l0 c" by blast
    with foldli_not_cond [of c \<sigma> l0 f, OF not_c]
    show ?thesis by simp
  qed

  lemma iti_stop_rule_emp :
    assumes S0_emp: "S0 = {}"
    shows "iti c f \<sigma> = \<sigma>"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "S0 = set l0" "iti c = foldli l0 c" by blast
    with foldli.simps(1) [of c f \<sigma>] S0_emp
    show ?thesis by simp
  qed

  text \<open>Reducing everything to folding is cumbersome. Let's
          define a few high-level inference rules.\<close>

  lemma iteratei_rule_P:
    assumes
      "I S0 \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0;
                 \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0 - S. R y x\<rbrakk>
                 \<Longrightarrow> I (S - {x}) (f x \<sigma>)"
      "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> c \<sigma>; I S \<sigma>;
               \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iti c f \<sigma>0)"
  proof -
    { fix P I \<sigma>0 f
      assume
        I: "I S0 \<sigma>0" and
        R: "\<And>S \<sigma> x. \<lbrakk>c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>S-{x}. R x y\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>)" and
        C1: "I {} (iti c f \<sigma>0) \<Longrightarrow> P" and
        C2:"\<And>S. \<lbrakk>S \<subseteq> S0; S \<noteq> {}; \<not> c (iti c f \<sigma>0); I S (iti c f \<sigma>0)\<rbrakk> \<Longrightarrow> P"

      from foldli_transform obtain l0 where l0_props:
         "distinct l0" "S0 = set l0" "sorted_wrt R l0"  "iti c = foldli l0 c" by auto

      from I R
      have "I {} (iti c f \<sigma>0) \<or>
          (\<exists>S. S \<subseteq> S0 \<and> S \<noteq> {} \<and>
               \<not> (c (iti c f \<sigma>0)) \<and>
               I S (iti c f \<sigma>0))"
        unfolding l0_props using l0_props(1,3)
      proof (induct l0 arbitrary: \<sigma>0)
        case Nil thus ?case by simp
      next
        case (Cons x l0)
        note ind_hyp = Cons(1)
        note I_x_l0 = Cons(2)
        note step = Cons(3)
        from Cons(4) have dist_l0: "distinct l0" and x_nin_l0: "x \<notin> set l0" by simp_all
        from Cons(5) have R_l0: "\<forall>y\<in>set l0. R x y" and
                          sort_l0: "sorted_wrt R l0" by simp_all

        show ?case
        proof (cases "c \<sigma>0")
          case False
          with I_x_l0 show ?thesis
            apply (rule_tac disjI2)
            apply (rule_tac exI[where x="set (x # l0)"])
            apply (simp)
          done
        next
          case True note c_\<sigma>0 = this

          from step[of \<sigma>0 x "set (x # l0)"] I_x_l0 R_l0 c_\<sigma>0 x_nin_l0
          have step': "I (set l0) (f x \<sigma>0)"
            by (simp_all add: Ball_def)

          from ind_hyp [OF step' step dist_l0 sort_l0]
          have "I {} (foldli l0 c f (f x \<sigma>0)) \<or>
                (\<exists>S. S \<subseteq> set l0 \<and> S \<noteq> {} \<and>
                \<not> c (foldli l0 c f (f x \<sigma>0)) \<and> I S (foldli l0 c f (f x \<sigma>0)))"
            by (fastforce)
          thus ?thesis
            by (simp add: c_\<sigma>0 subset_iff) metis
        qed
      qed
      with C1 C2 have "P" by blast
    } note aux = this

    from assms
    show ?thesis
      apply (rule_tac aux [of "\<lambda>S \<sigma>. I S \<sigma> \<and> (\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x)" \<sigma>0 f])
      apply auto
    done
  qed

  text \<open>Instead of removing elements one by one from the invariant, adding them is sometimes more natural.\<close>
  lemma iteratei_rule_insert_P:
  assumes pre :
      "I {} \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>(S0 - S) - {x}. R x y;
                 \<forall>y\<in>S. R y x\<rbrakk>
                  \<Longrightarrow> I (insert x S) (f x \<sigma>)"
      "\<And>\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> S0;
              \<not> (c \<sigma>); I S \<sigma>; \<forall>x\<in>S0-S. \<forall>y\<in>S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
  proof -
    let ?I' = "\<lambda>S \<sigma>. I (S0 - S) \<sigma>"

    have pre1:
      "!!\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> (c \<sigma>); ?I' S \<sigma>;
             \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x\<rbrakk> \<Longrightarrow> P \<sigma>"
    proof -
      fix S \<sigma>
      assume AA:
        "S \<subseteq> S0" "S \<noteq> {}"
        "\<not> (c \<sigma>)"
        "?I' S \<sigma>" "\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x"
      with pre(4) [of "S0 - S"]
      show "P \<sigma>" by auto
    qed

    have pre2 :"\<And>x S \<sigma>. \<lbrakk>c \<sigma>; x \<in> S; S \<subseteq> S0; ?I' S \<sigma>; \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> ?I' (S - {x}) (f x \<sigma>)"
    proof -
      fix x S \<sigma>
      assume AA : "c \<sigma>" "x \<in> S" "S \<subseteq> S0" "?I' S \<sigma>" "\<forall>y\<in>S - {x}. R x y" "\<forall>y\<in>S0 - S. R y x"

      from AA(2) AA(3) have "S0 - (S - {x}) = insert x (S0 - S)" "S0 - (S0 - S) = S" by auto
      moreover
      note pre(2) [of \<sigma> x "S0 - S"] AA
      ultimately show "?I' (S - {x}) (f x \<sigma>)"
        by auto
    qed

    show "P (iti c f \<sigma>0)"
      apply (rule iteratei_rule_P [of ?I' \<sigma>0 c f P])
      apply (simp add: pre)
      apply (rule pre2) apply simp_all
      apply (simp add: pre(3))
      apply (simp add: pre1)
    done
  qed

  text \<open>Show that iti without interruption is related to fold\<close>
  lemma iti_fold:
  assumes lc_f: "comp_fun_commute f"
    shows "iti (\<lambda>_. True) f \<sigma>0 = Finite_Set.fold f \<sigma>0 S0"
  proof (rule iteratei_rule_insert_P [where I = "\<lambda>X \<sigma>'. \<sigma>' = Finite_Set.fold f \<sigma>0 X"])
    fix S \<sigma> x
    assume "x \<in> S0 - S" "S \<subseteq> S0" and \<sigma>_eq: "\<sigma> = Finite_Set.fold f \<sigma>0 S"
    from finite_S0 \<open>S \<subseteq> S0\<close> have fin_S: "finite S" by (metis finite_subset)
    from \<open>x \<in> S0 - S\<close> have x_nin_S: "x \<notin> S" by simp
    note fold_eq = comp_fun_commute.fold_insert [OF lc_f fin_S x_nin_S]

    show "f x \<sigma> = Finite_Set.fold f \<sigma>0 (insert x S)"
      by (simp add: fold_eq \<sigma>_eq)
  qed simp_all
end

subsection \<open>Iterators over Maps\<close>

type_synonym ('k,'v,'\<sigma>) map_iterator = "('k\<times>'v,'\<sigma>) set_iterator"

text \<open>Iterator over the key-value pairs of a finite map are called iterators over maps.\<close>
abbreviation "map_iterator_genord it m R \<equiv> set_iterator_genord it (map_to_set m) R"

subsection \<open>Unordered Iterators\<close>

text \<open>Often one does not care about the order in which the elements are processed.
        Therefore, the selection function can be set to not impose any further restrictings.
        This leads to considerably simpler theorems.\<close>

definition "set_iterator it S0 \<equiv> set_iterator_genord it S0 (\<lambda>_ _. True)"
abbreviation "map_iterator it m \<equiv> set_iterator it (map_to_set m)"

lemma set_iterator_intro :
    "set_iterator_genord it S0 R \<Longrightarrow> set_iterator it S0"
unfolding set_iterator_def
apply (rule set_iterator_genord.set_iterator_weaken_R [where R = R])
apply simp_all
done

lemma set_iterator_no_cond_rule_P:
"\<lbrakk> set_iterator it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
by simp

lemma set_iterator_no_cond_rule_insert_P:
"\<lbrakk> set_iterator it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
by simp

lemma set_iterator_rule_P:
"\<lbrakk> set_iterator it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

lemma set_iterator_rule_insert_P:
"\<lbrakk> set_iterator it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

text\<open>The following rules is adapted for maps. Instead of a set of key-value pairs the invariant
       now only sees the keys.\<close>
lemma map_iterator_genord_rule_P:
  assumes "map_iterator_genord it m R"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> it-{k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                             \<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)\<rbrakk> \<Longrightarrow>
                            I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                                     R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
proof (rule set_iterator_genord.iteratei_rule_P [of it "map_to_set m" R "\<lambda>S \<sigma>. I (fst ` S) \<sigma>" \<sigma>0 c f P])
  show "map_iterator_genord it m R" by fact
next
  show "I (fst ` map_to_set m) \<sigma>0" using I0 by (simp add: map_to_set_dom[symmetric])
next
  fix \<sigma>
  assume "I (fst ` {}) \<sigma>"
  with IF show "P \<sigma>" by simp
next
  fix \<sigma> S
  assume "S \<subseteq> map_to_set m" "S \<noteq> {}" "\<not> c \<sigma>" "I (fst ` S) \<sigma>"
         and R_prop: "\<forall>x\<in>S. \<forall>y\<in>map_to_set m - S. R y x"
  let ?S' = "fst ` S"

  show "P \<sigma>"
  proof (rule II [where it = ?S'])
    from \<open>S \<subseteq> map_to_set m\<close>
    show "?S' \<subseteq> dom m"
      unfolding map_to_set_dom
      by auto
  next
    from \<open>S \<noteq> {}\<close> show "?S' \<noteq> {}" by auto
  next
    show "\<not> (c \<sigma>)" by fact
  next
    show "I (fst ` S) \<sigma>" by fact
  next
    show "\<forall>k v k' v'.
       k \<notin> fst ` S \<and>
       m k = Some v \<and>
       k' \<in> fst ` S \<and> m k' = Some v' \<longrightarrow>
       R (k, v) (k', v')"
    proof (intro allI impI, elim conjE )
      fix k v k' v'
      assume pre_k: "k \<notin> fst ` S" "m k = Some v"
      assume pre_k': "k' \<in> fst ` S" "m k' = Some v'"

      from \<open>S \<subseteq> map_to_set m\<close> pre_k'
      have kv'_in: "(k', v') \<in> S"
        unfolding map_to_set_def by auto

      from \<open>S \<subseteq> map_to_set m\<close> pre_k
      have kv_in: "(k, v) \<in> map_to_set m - S"
        unfolding map_to_set_def
        by (auto simp add: image_iff)

      from R_prop kv_in kv'_in
      show "R (k, v) (k',v')" by simp
    qed
  qed
next
  fix \<sigma> S kv
  assume "S \<subseteq> map_to_set m" "kv \<in> S" "c \<sigma>" and I_S': "I (fst ` S) \<sigma>" and
         R_S: "\<forall>kv'\<in>S - {kv}. R kv kv'" and
         R_not_S: "\<forall>kv'\<in>map_to_set m - S. R kv' kv"
  let ?S' = "fst ` S"
  obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)

  have "I (fst ` S - {k}) (f (k, v) \<sigma>)"
  proof (rule IP)
    show "c \<sigma>" by fact
  next
    from \<open>kv \<in> S\<close> show "k \<in> ?S'" by (auto simp add: image_iff Bex_def)
  next
    from \<open>kv \<in> S\<close> \<open>S \<subseteq> map_to_set m\<close>
    have "kv \<in> map_to_set m" by auto
    thus m_k_eq: "m k = Some v" unfolding map_to_set_def by simp
  next
    from \<open>S \<subseteq> map_to_set m\<close>
    show S'_subset: "?S' \<subseteq> dom m"
      unfolding map_to_set_dom
      by auto
  next
    show "I (fst ` S) \<sigma>" by fact
  next
    from \<open>S \<subseteq> map_to_set m\<close> \<open>kv \<in> S\<close>
    have S_simp: "{(k', v'). k' \<in> (fst ` S) - {k} \<and> m k' = Some v'} = S - {kv}"
      unfolding map_to_set_def subset_iff
      apply (auto simp add: image_iff Bex_def)
      apply (metis option.inject)
    done

    from R_S[unfolded S_simp[symmetric]] R_not_S
    show "\<forall>k' v'. k' \<in> fst ` S - {k} \<and> m k' = Some v' \<longrightarrow>
                  R (k, v) (k', v') "
      by simp
  next
    from \<open>S \<subseteq> map_to_set m\<close> R_not_S
    show "\<forall>k' v'. k' \<notin> fst ` S \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)"
      apply (simp add: Ball_def map_to_set_def subset_iff image_iff)
      apply metis
    done
  qed

  moreover
    from \<open>S \<subseteq> map_to_set m\<close> \<open>kv \<in> S\<close>
    have "fst ` (S - {kv}) = fst ` S - {k}"
      apply (simp add: set_eq_iff image_iff Bex_def map_to_set_def subset_iff)
      apply (metis option.inject)
    done

  ultimately show "I (fst ` (S - {kv})) (f kv \<sigma>)" by simp
qed

lemma map_iterator_genord_rule_insert_P:
  assumes "map_iterator_genord it m R"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> (dom m - it) - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                             \<forall>k' v'. k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                               R (k', v') (k, v)\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<in> it \<and> m k = Some v \<and> k' \<notin> it \<and> m k' = Some v' \<longrightarrow>
                                     R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
proof (rule map_iterator_genord_rule_P [of it m R "\<lambda>S \<sigma>. I (dom m - S) \<sigma>"])
  show "map_iterator_genord it m R" by fact
next
  show "I (dom m - dom m) \<sigma>0" using I0 by simp
next
  fix \<sigma>
  assume "I (dom m - {}) \<sigma>"
  with IF show "P \<sigma>" by simp
next
  fix \<sigma> it
  assume assms: "it \<subseteq> dom m" "it \<noteq> {}" "\<not> c \<sigma>" "I (dom m - it) \<sigma>"
                "\<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                             R (k, v) (k', v')"
  from assms have "dom m - it \<noteq> dom m" by auto
  with II[of "dom m - it" \<sigma>] assms
  show "P \<sigma>"
    apply (simp add: subset_iff dom_def)
    apply (metis option.simps(2))
  done
next
  fix k v it \<sigma>
  assume assms: "c \<sigma>" "k \<in> it" "m k = Some v" "it \<subseteq> dom m" "I (dom m - it) \<sigma>"
                "\<forall>k' v'. k' \<in> it - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v')"
                "\<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)"

  hence "insert k (dom m - it) = (dom m - (it - {k}))" "dom m - (dom m - it) = it" by auto
  with assms IP[of \<sigma> k "dom m - it" v]
  show "I (dom m - (it - {k})) (f (k, v) \<sigma>)" by (simp_all add: subset_iff)
qed

lemma map_iterator_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (it (\<lambda>_. True) f \<sigma>0)"
using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (it (\<lambda>_. True) f \<sigma>0)"
using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
unfolding set_iterator_def
by simp

subsection \<open>Ordered Iterators\<close>

text \<open>Selecting according to a linear order is another case that is interesting.
 Ordered iterators over maps, i.\,e.\ iterators over key-value pairs,
 use an order on the keys.\<close>

context linorder begin
  definition "set_iterator_linord it S0
    \<equiv> set_iterator_genord it S0 (\<le>)"
  definition "set_iterator_rev_linord it S0
    \<equiv> set_iterator_genord it S0 (\<ge>)"
  definition "set_iterator_map_linord it S0 \<equiv>
     set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<le>k')"
  definition "set_iterator_map_rev_linord it S0 \<equiv>
     set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<ge>k')"
  abbreviation "map_iterator_linord it m \<equiv>
    set_iterator_map_linord it (map_to_set m)"
  abbreviation "map_iterator_rev_linord it m \<equiv>
    set_iterator_map_rev_linord it (map_to_set m)"

  lemma set_iterator_linord_rule_P:
  "\<lbrakk> set_iterator_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(\<le>)" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_linord_rule_insert_P:
  "\<lbrakk> set_iterator_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x \<le> x'\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(\<le>)" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_P:
  "\<lbrakk> set_iterator_rev_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(\<ge>)" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_insert_P:
  "\<lbrakk> set_iterator_rev_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x' \<le> x\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow>  (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(\<ge>)" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_map_linord_rule_P:
  "\<lbrakk> set_iterator_map_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k' \<le> k;
                  \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
         \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_linord_rule_insert_P:
  "\<lbrakk> set_iterator_map_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k;
                  \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k \<le> k'\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_P:
  "\<lbrakk> set_iterator_map_rev_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k \<le> k';
                  \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_insert_P:
  "\<lbrakk> set_iterator_map_rev_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k';
                 \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k' \<le> k\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma map_iterator_linord_rule_P:
    assumes "map_iterator_linord it m"
        and I0: "I (dom m) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k';
                 \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_linord_rule_insert_P:
    assumes "map_iterator_linord it m"
        and I0: "I {} \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k \<le> k';
                 \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto

  lemma map_iterator_rev_linord_rule_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I (dom m) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k;
                 \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_rev_linord_rule_insert_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I {} \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k' \<le> k;
                 \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto
end

subsection \<open>Conversions to foldli\<close>

lemma set_iterator_genord_foldli_conv :
  "set_iterator_genord iti S R \<longleftrightarrow>
   (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0)"
unfolding set_iterator_genord_def by simp

lemma set_iterator_genord_I [intro] :
  "\<lbrakk>distinct l0; S = set l0; sorted_wrt R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   set_iterator_genord iti S R" unfolding set_iterator_genord_foldli_conv
   by blast

lemma set_iterator_foldli_conv :
  "set_iterator iti S \<longleftrightarrow>
   (\<exists>l0. distinct l0 \<and> S = set l0 \<and> iti = foldli l0)"
unfolding set_iterator_def set_iterator_genord_def by simp

lemma set_iterator_I [intro] :
  "\<lbrakk>distinct l0; S = set l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   set_iterator iti S"
   unfolding set_iterator_foldli_conv
   by blast

context linorder begin
  lemma set_iterator_linord_foldli_conv :
    "set_iterator_linord iti S \<longleftrightarrow>
     (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted l0 \<and> iti = foldli l0)"
  unfolding set_iterator_linord_def set_iterator_genord_def by (simp add: sorted_sorted_wrt)

  lemma set_iterator_linord_I [intro] :
    "\<lbrakk>distinct l0; S = set l0; sorted l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
     set_iterator_linord iti S"
     unfolding set_iterator_linord_foldli_conv
     by blast

  lemma set_iterator_rev_linord_foldli_conv :
    "set_iterator_rev_linord iti S \<longleftrightarrow>
     (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted (rev l0) \<and> iti = foldli l0)"
  unfolding set_iterator_rev_linord_def set_iterator_genord_def by simp

  lemma set_iterator_rev_linord_I [intro] :
    "\<lbrakk>distinct l0; S = set l0; sorted (rev l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
     set_iterator_rev_linord iti S"
     unfolding set_iterator_rev_linord_foldli_conv
     by blast
end

lemma map_iterator_genord_foldli_conv :
  "map_iterator_genord iti m R \<longleftrightarrow>
   (\<exists>(l0::('k \<times> 'v) list). distinct (map fst l0) \<and> m = map_of l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0)"
proof -
  { fix l0 :: "('k \<times> 'v) list"
    assume dist: "distinct l0"
    have "(map_to_set m = set l0) \<longleftrightarrow>
          (distinct (map fst l0) \<and>
           m = map_of l0)"
    proof (cases "distinct (map fst l0)")
      case True thus ?thesis by (metis map_of_map_to_set)
    next
      case False note not_dist_fst = this

      with dist have "~(inj_on fst (set l0))" by (simp add: distinct_map)
      hence "set l0 \<noteq> map_to_set m"
        by (rule_tac notI) (simp add: map_to_set_def inj_on_def)
      with not_dist_fst show ?thesis by simp
    qed
  }
  thus ?thesis
    unfolding set_iterator_genord_def distinct_map
    by metis
qed

lemma map_iterator_genord_I [intro] :
  "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted_wrt R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   map_iterator_genord iti m R"
   unfolding map_iterator_genord_foldli_conv
   by blast

lemma map_iterator_foldli_conv :
  "map_iterator iti m \<longleftrightarrow>
   (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> iti = foldli l0)"
unfolding set_iterator_def map_iterator_genord_foldli_conv
by simp

lemma map_iterator_I [intro] :
  "\<lbrakk>distinct (map fst l0); m = map_of l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   map_iterator iti m"
   unfolding map_iterator_foldli_conv
   by blast

context linorder begin

  lemma sorted_wrt_keys_map_fst:
    "sorted_wrt (\<lambda>(k,_) (k',_). R k k') l = sorted_wrt R (map fst l)"
    by (induct l) auto

  lemma map_iterator_linord_foldli_conv :
    "map_iterator_linord iti m \<longleftrightarrow>
     (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (map fst l0) \<and> iti = foldli l0)"
  unfolding set_iterator_map_linord_def map_iterator_genord_foldli_conv
  by (simp add: sorted_wrt_keys_map_fst sorted_sorted_wrt)

  lemma map_iterator_linord_I [intro] :
    "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted (map fst l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
     map_iterator_linord iti m"
     unfolding map_iterator_linord_foldli_conv
     by blast

  lemma map_iterator_rev_linord_foldli_conv :
    "map_iterator_rev_linord iti m \<longleftrightarrow>
     (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (rev (map fst l0)) \<and> iti = foldli l0)"
  unfolding set_iterator_map_rev_linord_def map_iterator_genord_foldli_conv
  by (simp add: sorted_wrt_keys_map_fst)

end

end


(*  Title:      HOL/Library/Countable.thy
    Author:     Alexander Krauss, TU Muenchen
    Author:     Brian Huffman, Portland State University
    Author:     Jasmin Blanchette, TU Muenchen
*)

section {* Encoding (almost) everything into natural numbers *}

theory Countable
imports Old_Datatype Rat Nat_Bijection
begin

subsection {* The class of countable types *}

class countable =
  assumes ex_inj: "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat"

lemma countable_classI:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "OFCLASS('a, countable_class)"
proof (intro_classes, rule exI)
  show "inj f"
    by (rule injI [OF assms]) assumption
qed

subsection {* Conversion functions *}

definition to_nat :: "'a\<Colon>countable \<Rightarrow> nat" where
  "to_nat = (SOME f. inj f)"

definition from_nat :: "nat \<Rightarrow> 'a\<Colon>countable" where
  "from_nat = inv (to_nat \<Colon> 'a \<Rightarrow> nat)"

lemma inj_to_nat [simp]: "inj to_nat"
  by (rule exE_some [OF ex_inj]) (simp add: to_nat_def)

lemma inj_on_to_nat[simp, intro]: "inj_on to_nat S"
  using inj_to_nat by (auto simp: inj_on_def)

lemma surj_from_nat [simp]: "surj from_nat"
  unfolding from_nat_def by (simp add: inj_imp_surj_inv)

lemma to_nat_split [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
  using injD [OF inj_to_nat] by auto

lemma from_nat_to_nat [simp]:
  "from_nat (to_nat x) = x"
  by (simp add: from_nat_def)

subsection {* Finite types are countable *}

subclass (in finite) countable
proof
  have "finite (UNIV\<Colon>'a set)" by (rule finite_UNIV)
  with finite_conv_nat_seg_image [of "UNIV::'a set"]
  obtain n and f :: "nat \<Rightarrow> 'a"
    where "UNIV = f ` {i. i < n}" by auto
  then have "surj f" unfolding surj_def by auto
  then have "inj (inv f)" by (rule surj_imp_inj_inv)
  then show "\<exists>to_nat \<Colon> 'a \<Rightarrow> nat. inj to_nat" by (rule exI[of inj])
qed

subsection {* Automatically proving countability of old-style datatypes *}

inductive finite_item :: "'a Old_Datatype.item \<Rightarrow> bool" where
  undefined: "finite_item undefined"
| In0: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In0 x)"
| In1: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In1 x)"
| Leaf: "finite_item (Old_Datatype.Leaf a)"
| Scons: "\<lbrakk>finite_item x; finite_item y\<rbrakk> \<Longrightarrow> finite_item (Old_Datatype.Scons x y)"

function
  nth_item :: "nat \<Rightarrow> ('a::countable) Old_Datatype.item"
where
  "nth_item 0 = undefined"
| "nth_item (Suc n) =
  (case sum_decode n of
    Inl i \<Rightarrow>
    (case sum_decode i of
      Inl j \<Rightarrow> Old_Datatype.In0 (nth_item j)
    | Inr j \<Rightarrow> Old_Datatype.In1 (nth_item j))
  | Inr i \<Rightarrow>
    (case sum_decode i of
      Inl j \<Rightarrow> Old_Datatype.Leaf (from_nat j)
    | Inr j \<Rightarrow>
      (case prod_decode j of
        (a, b) \<Rightarrow> Old_Datatype.Scons (nth_item a) (nth_item b))))"
by pat_completeness auto

lemma le_sum_encode_Inl: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inl y)"
unfolding sum_encode_def by simp

lemma le_sum_encode_Inr: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inr y)"
unfolding sum_encode_def by simp

termination
by (relation "measure id")
  (auto simp add: sum_encode_eq [symmetric] prod_encode_eq [symmetric]
    le_imp_less_Suc le_sum_encode_Inl le_sum_encode_Inr
    le_prod_encode_1 le_prod_encode_2)

lemma nth_item_covers: "finite_item x \<Longrightarrow> \<exists>n. nth_item n = x"
proof (induct set: finite_item)
  case undefined
  have "nth_item 0 = undefined" by simp
  thus ?case ..
next
  case (In0 x)
  then obtain n where "nth_item n = x" by fast
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inl n))))) = Old_Datatype.In0 x" by simp
  thus ?case ..
next
  case (In1 x)
  then obtain n where "nth_item n = x" by fast
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inr n))))) = Old_Datatype.In1 x" by simp
  thus ?case ..
next
  case (Leaf a)
  have "nth_item (Suc (sum_encode (Inr (sum_encode (Inl (to_nat a)))))) = Old_Datatype.Leaf a"
    by simp
  thus ?case ..
next
  case (Scons x y)
  then obtain i j where "nth_item i = x" and "nth_item j = y" by fast
  hence "nth_item
    (Suc (sum_encode (Inr (sum_encode (Inr (prod_encode (i, j))))))) = Old_Datatype.Scons x y"
    by simp
  thus ?case ..
qed

theorem countable_datatype:
  fixes Rep :: "'b \<Rightarrow> ('a::countable) Old_Datatype.item"
  fixes Abs :: "('a::countable) Old_Datatype.item \<Rightarrow> 'b"
  fixes rep_set :: "('a::countable) Old_Datatype.item \<Rightarrow> bool"
  assumes type: "type_definition Rep Abs (Collect rep_set)"
  assumes finite_item: "\<And>x. rep_set x \<Longrightarrow> finite_item x"
  shows "OFCLASS('b, countable_class)"
proof
  def f \<equiv> "\<lambda>y. LEAST n. nth_item n = Rep y"
  {
    fix y :: 'b
    have "rep_set (Rep y)"
      using type_definition.Rep [OF type] by simp
    hence "finite_item (Rep y)"
      by (rule finite_item)
    hence "\<exists>n. nth_item n = Rep y"
      by (rule nth_item_covers)
    hence "nth_item (f y) = Rep y"
      unfolding f_def by (rule LeastI_ex)
    hence "Abs (nth_item (f y)) = y"
      using type_definition.Rep_inverse [OF type] by simp
  }
  hence "inj f"
    by (rule inj_on_inverseI)
  thus "\<exists>f::'b \<Rightarrow> nat. inj f"
    by - (rule exI)
qed

ML {*
  fun old_countable_datatype_tac ctxt =
    SUBGOAL (fn (goal, _) =>
      let
        val ty_name =
          (case goal of
            (_ $ Const (@{const_name Pure.type}, Type (@{type_name itself}, [Type (n, _)]))) => n
          | _ => raise Match)
        val typedef_info = hd (Typedef.get_info ctxt ty_name)
        val typedef_thm = #type_definition (snd typedef_info)
        val pred_name =
          (case HOLogic.dest_Trueprop (concl_of typedef_thm) of
            (_ $ _ $ _ $ (_ $ Const (n, _))) => n
          | _ => raise Match)
        val induct_info = Inductive.the_inductive ctxt pred_name
        val pred_names = #names (fst induct_info)
        val induct_thms = #inducts (snd induct_info)
        val alist = pred_names ~~ induct_thms
        val induct_thm = the (AList.lookup (op =) alist pred_name)
        val vars = rev (Term.add_vars (Thm.prop_of induct_thm) [])
        val thy = Proof_Context.theory_of ctxt
        val insts = vars |> map (fn (_, T) => try (Thm.cterm_of thy)
          (Const (@{const_name Countable.finite_item}, T)))
        val induct_thm' = Drule.instantiate' [] insts induct_thm
        val rules = @{thms finite_item.intros}
      in
        SOLVED' (fn i => EVERY
          [rtac @{thm countable_datatype} i,
           rtac typedef_thm i,
           etac induct_thm' i,
           REPEAT (resolve_tac rules i ORELSE atac i)]) 1
      end)
*}

hide_const (open) finite_item nth_item

subsection {* Automatically proving countability of datatypes *}

ML_file "bnf_lfp_countable.ML"

ML {*
fun countable_datatype_tac ctxt st =
  HEADGOAL (old_countable_datatype_tac ctxt) st
  handle exn =>
    if Exn.is_interrupt exn then reraise exn else BNF_LFP_Countable.countable_datatype_tac ctxt st;

(* compatibility *)
fun countable_tac ctxt =
  SELECT_GOAL (countable_datatype_tac ctxt);
*}

method_setup countable_datatype = {*
  Scan.succeed (SIMPLE_METHOD o countable_datatype_tac)
*} "prove countable class instances for datatypes"

subsection {* More Countable types *}

text {* Naturals *}

instance nat :: countable
  by (rule countable_classI [of "id"]) simp

text {* Pairs *}

instance prod :: (countable, countable) countable
  by (rule countable_classI [of "\<lambda>(x, y). prod_encode (to_nat x, to_nat y)"])
    (auto simp add: prod_encode_eq)

text {* Sums *}

instance sum :: (countable, countable) countable
  by (rule countable_classI [of "(\<lambda>x. case x of Inl a \<Rightarrow> to_nat (False, to_nat a)
                                     | Inr b \<Rightarrow> to_nat (True, to_nat b))"])
    (simp split: sum.split_asm)

text {* Integers *}

instance int :: countable
  by (rule countable_classI [of int_encode]) (simp add: int_encode_eq)

text {* Options *}

instance option :: (countable) countable
  by countable_datatype

text {* Lists *}

instance list :: (countable) countable
  by countable_datatype

text {* String literals *}

instance String.literal :: countable
  by (rule countable_classI [of "to_nat \<circ> String.explode"]) (auto simp add: explode_inject)

text {* Functions *}

instance "fun" :: (finite, countable) countable
proof
  obtain xs :: "'a list" where xs: "set xs = UNIV"
    using finite_list [OF finite_UNIV] ..
  show "\<exists>to_nat::('a \<Rightarrow> 'b) \<Rightarrow> nat. inj to_nat"
  proof
    show "inj (\<lambda>f. to_nat (map f xs))"
      by (rule injI, simp add: xs fun_eq_iff)
  qed
qed

text {* Typereps *}

instance typerep :: countable
  by countable_datatype

subsection {* The rationals are countably infinite *}

definition nat_to_rat_surj :: "nat \<Rightarrow> rat" where
  "nat_to_rat_surj n = (let (a, b) = prod_decode n in Fract (int_decode a) (int_decode b))"

lemma surj_nat_to_rat_surj: "surj nat_to_rat_surj"
unfolding surj_def
proof
  fix r::rat
  show "\<exists>n. r = nat_to_rat_surj n"
  proof (cases r)
    fix i j assume [simp]: "r = Fract i j" and "j > 0"
    have "r = (let m = int_encode i; n = int_encode j in nat_to_rat_surj (prod_encode (m, n)))"
      by (simp add: Let_def nat_to_rat_surj_def)
    thus "\<exists>n. r = nat_to_rat_surj n" by(auto simp: Let_def)
  qed
qed

lemma Rats_eq_range_nat_to_rat_surj: "\<rat> = range nat_to_rat_surj"
  by (simp add: Rats_def surj_nat_to_rat_surj)

context field_char_0
begin

lemma Rats_eq_range_of_rat_o_nat_to_rat_surj:
  "\<rat> = range (of_rat \<circ> nat_to_rat_surj)"
  using surj_nat_to_rat_surj
  by (auto simp: Rats_def image_def surj_def) (blast intro: arg_cong[where f = of_rat])

lemma surj_of_rat_nat_to_rat_surj:
  "r \<in> \<rat> \<Longrightarrow> \<exists>n. r = of_rat (nat_to_rat_surj n)"
  by (simp add: Rats_eq_range_of_rat_o_nat_to_rat_surj image_def)

end

instance rat :: countable
proof
  show "\<exists>to_nat::rat \<Rightarrow> nat. inj to_nat"
  proof
    have "surj nat_to_rat_surj"
      by (rule surj_nat_to_rat_surj)
    then show "inj (inv nat_to_rat_surj)"
      by (rule surj_imp_inj_inv)
  qed
qed

end


(*  Title:      HOL/Nonstandard_Analysis/CLim.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2001 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section\<open>Limits, Continuity and Differentiation for Complex Functions\<close>

theory CLim
imports CStar
begin

(*not in simpset?*)
declare hypreal_epsilon_not_zero [simp]

(*??generalize*)
lemma lemma_complex_mult_inverse_squared [simp]:
     "x \<noteq> (0::complex) \<Longrightarrow> x * (inverse x)\<^sup>2 = inverse x"
by (simp add: numeral_2_eq_2)

text\<open>Changing the quantified variable. Install earlier?\<close>
lemma all_shift: "(\<forall>x::'a::comm_ring_1. P x) = (\<forall>x. P (x-a))"
apply auto
apply (drule_tac x="x+a" in spec)
apply (simp add: add.assoc)
done

lemma complex_add_minus_iff [simp]: "(x + - a = (0::complex)) = (x=a)"
by (simp add: diff_eq_eq)

lemma complex_add_eq_0_iff [iff]: "(x+y = (0::complex)) = (y = -x)"
apply auto
apply (drule sym [THEN diff_eq_eq [THEN iffD2]], auto)
done

subsection\<open>Limit of Complex to Complex Function\<close>

lemma NSLIM_Re: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L ==> (%x. Re(f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Re(L)"
by (simp add: NSLIM_def starfunC_approx_Re_Im_iff
              hRe_hcomplex_of_complex)

lemma NSLIM_Im: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L ==> (%x. Im(f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Im(L)"
by (simp add: NSLIM_def starfunC_approx_Re_Im_iff
              hIm_hcomplex_of_complex)

(** get this result easily now **)
lemma LIM_Re:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f \<midarrow>a\<rightarrow> L ==> (%x. Re(f x)) \<midarrow>a\<rightarrow> Re(L)"
by (simp add: LIM_NSLIM_iff NSLIM_Re)

lemma LIM_Im:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f \<midarrow>a\<rightarrow> L ==> (%x. Im(f x)) \<midarrow>a\<rightarrow> Im(L)"
by (simp add: LIM_NSLIM_iff NSLIM_Im)

lemma LIM_cnj:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f \<midarrow>a\<rightarrow> L ==> (%x. cnj (f x)) \<midarrow>a\<rightarrow> cnj L"
by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma LIM_cnj_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "((%x. cnj (f x)) \<midarrow>a\<rightarrow> cnj L) = (f \<midarrow>a\<rightarrow> L)"
by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma starfun_norm: "( *f* (\<lambda>x. norm (f x))) = (\<lambda>x. hnorm (( *f* f) x))"
by transfer (rule refl)

lemma star_of_Re [simp]: "star_of (Re x) = hRe (star_of x)"
by transfer (rule refl)

lemma star_of_Im [simp]: "star_of (Im x) = hIm (star_of x)"
by transfer (rule refl)

text""
(** another equivalence result **)
lemma NSCLIM_NSCRLIM_iff:
   "(f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S L) = ((%y. cmod(f y - L)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0)"
by (simp add: NSLIM_def starfun_norm
    approx_approx_zero_iff [symmetric] approx_minus_iff [symmetric])

(** much, much easier standard proof **)
lemma CLIM_CRLIM_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "(f \<midarrow>x\<rightarrow> L) = ((%y. cmod(f y - L)) \<midarrow>x\<rightarrow> 0)"
by (simp add: LIM_eq)

(* so this is nicer nonstandard proof *)
lemma NSCLIM_NSCRLIM_iff2:
     "(f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S L) = ((%y. cmod(f y - L)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0)"
by (simp add: LIM_NSLIM_iff [symmetric] CLIM_CRLIM_iff)

lemma NSLIM_NSCRLIM_Re_Im_iff:
     "(f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L) = ((%x. Re(f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Re(L) &
                            (%x. Im(f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Im(L))"
apply (auto intro: NSLIM_Re NSLIM_Im)
apply (auto simp add: NSLIM_def starfun_Re starfun_Im)
apply (auto dest!: spec)
apply (simp add: hcomplex_approx_iff)
done

lemma LIM_CRLIM_Re_Im_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "(f \<midarrow>a\<rightarrow> L) = ((%x. Re(f x)) \<midarrow>a\<rightarrow> Re(L) &
                         (%x. Im(f x)) \<midarrow>a\<rightarrow> Im(L))"
by (simp add: LIM_NSLIM_iff NSLIM_NSCRLIM_Re_Im_iff)

subsection\<open>Continuity\<close>

lemma NSLIM_isContc_iff:
     "(f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S f a) = ((%h. f(a + h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S f a)"
by (rule NSLIM_h_iff)

subsection\<open>Functions from Complex to Reals\<close>

lemma isNSContCR_cmod [simp]: "isNSCont cmod (a)"
by (auto intro: approx_hnorm
         simp add: starfunCR_cmod hcmod_hcomplex_of_complex [symmetric]
                    isNSCont_def)

lemma isContCR_cmod [simp]: "isCont cmod (a)"
by (simp add: isNSCont_isCont_iff [symmetric])

lemma isCont_Re:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "isCont f a ==> isCont (%x. Re (f x)) a"
by (simp add: isCont_def LIM_Re)

lemma isCont_Im:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "isCont f a ==> isCont (%x. Im (f x)) a"
by (simp add: isCont_def LIM_Im)

subsection\<open>Differentiation of Natural Number Powers\<close>

lemma CDERIV_pow [simp]:
     "DERIV (%x. x ^ n) x :> (complex_of_real (real n)) * (x ^ (n - Suc 0))"
apply (induct n)
apply (drule_tac [2] DERIV_ident [THEN DERIV_mult])
apply (auto simp add: distrib_right of_nat_Suc)
apply (case_tac "n")
apply (auto simp add: ac_simps)
done

text\<open>Nonstandard version\<close>
lemma NSCDERIV_pow: "NSDERIV (%x. x ^ n) x :> complex_of_real (real n) * (x ^ (n - 1))"
    by (metis CDERIV_pow NSDERIV_DERIV_iff One_nat_def)

text\<open>Can't relax the premise @{term "x \<noteq> 0"}: it isn't continuous at zero\<close>
lemma NSCDERIV_inverse:
     "(x::complex) \<noteq> 0 ==> NSDERIV (%x. inverse(x)) x :> (- ((inverse x)\<^sup>2))"
unfolding numeral_2_eq_2
by (rule NSDERIV_inverse)

lemma CDERIV_inverse:
     "(x::complex) \<noteq> 0 ==> DERIV (%x. inverse(x)) x :> (- ((inverse x)\<^sup>2))"
unfolding numeral_2_eq_2
by (rule DERIV_inverse)

subsection\<open>Derivative of Reciprocals (Function @{term inverse})\<close>

lemma CDERIV_inverse_fun:
     "[| DERIV f x :> d; f(x) \<noteq> (0::complex) |]
      ==> DERIV (%x. inverse(f x)) x :> (- (d * inverse ((f x)\<^sup>2)))"
unfolding numeral_2_eq_2
by (rule DERIV_inverse_fun)

lemma NSCDERIV_inverse_fun:
     "[| NSDERIV f x :> d; f(x) \<noteq> (0::complex) |]
      ==> NSDERIV (%x. inverse(f x)) x :> (- (d * inverse ((f x)\<^sup>2)))"
unfolding numeral_2_eq_2
by (rule NSDERIV_inverse_fun)

subsection\<open>Derivative of Quotient\<close>

lemma CDERIV_quotient:
     "[| DERIV f x :> d; DERIV g x :> e; g(x) \<noteq> (0::complex) |]
       ==> DERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / ((g x)\<^sup>2)"
unfolding numeral_2_eq_2
by (rule DERIV_quotient)

lemma NSCDERIV_quotient:
     "[| NSDERIV f x :> d; NSDERIV g x :> e; g(x) \<noteq> (0::complex) |]
       ==> NSDERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / ((g x)\<^sup>2)"
unfolding numeral_2_eq_2
by (rule NSDERIV_quotient)

subsection\<open>Caratheodory Formulation of Derivative at a Point: Standard Proof\<close>

lemma CARAT_CDERIVD:
     "(\<forall>z. f z - f x = g z * (z - x)) & isNSCont g x & g x = l
      ==> NSDERIV f x :> l"
by clarify (rule CARAT_DERIVD)

end


theory SubRel
imports Graph
begin

section \<open>Graphs equipped with a subsumption relation\<close>

text \<open>In this section, we define subsumption relations and the notion of sub\hyp{}paths in
rooted graphs equipped with such relations. Sub-paths are defined in the same way than in
\verb?Graph.thy?: first we define the consistency of a sequence of edges in presence of a
subsumption relation, then sub-paths. We are interested in subsumptions taking places between red
vertices of red-black graphs (see \verb?RB.thy?), i.e.\ occurrences of locations of LTSs. Here
subsumptions are defined as pairs of indexed vertices of a LTS, and subsumption relations as sets
of subsumptions. The type of vertices of such LTSs is represented by the abstract type \<open>'v\<close>
in the following.\<close>

subsection \<open>Basic definitions and properties\<close>

subsubsection \<open>Subsumptions and subsumption relations\<close>

text \<open>Subsumptions take place between occurrences of the vertices of a graph. We represent
such occurrences by indexed versions of vertices. A subsumption is defined as pair of indexed
vertices.\<close>

type_synonym 'v sub_t = "(('v \<times> nat) \<times> ('v \<times> nat))"

text \<open>A subsumption relation is a set of subsumptions.\<close>

type_synonym 'v sub_rel_t = "'v sub_t set"

text \<open>We consider the left member to be subsumed by the right one. The left member of a
subsumption is called its \emph{subsumee}, the right member its \emph{subsumer}.\<close>

abbreviation subsumee ::
  "'v sub_t \<Rightarrow> ('v \<times> nat)"
where
  "subsumee sub \<equiv> fst sub"

abbreviation subsumer ::
  "'v sub_t \<Rightarrow> ('v \<times> nat)"
where
  "subsumer sub \<equiv> snd sub"

text \<open>We will need to talk about the sets of subsumees and subsumers of a subsumption relation.\<close>

abbreviation subsumees ::
  "'v sub_rel_t \<Rightarrow> ('v \<times> nat) set"
where
  "subsumees subs \<equiv> subsumee ` subs"

abbreviation subsumers ::
  "'v sub_rel_t \<Rightarrow> ('v \<times> nat) set"
where
  "subsumers subs \<equiv> subsumer ` subs"

text \<open>The two following lemmas will prove useful in the following.\<close>

lemma subsumees_conv :
  "subsumees subs = {v. \<exists> v'. (v,v') \<in> subs}"
by force

lemma subsumers_conv :
  "subsumers subs = {v'. \<exists> v. (v,v') \<in> subs}"
by force

text \<open>We call set of vertices of the relation the union of its sets of subsumees and subsumers.\<close>

abbreviation vertices ::
  "'v sub_rel_t \<Rightarrow> ('v \<times> nat) set"
where
  "vertices subs \<equiv> subsumers subs \<union> subsumees subs"

subsection \<open>Well-formed subsumption relation of a graph\<close>

subsubsection \<open>Well-formed subsumption relations\<close>

text \<open>In the following, we make an intensive use of \emph{locales}. We use them as a convenient
way to add assumptions to the following lemmas, in order to ease their reading. Locales can be
built from locales, allowing some modularity in the formalization. The following locale simply
states that we suppose there exists  a subsumption relation called \emph{subs}. It will
be used later in order to constrain subsumption relations.\<close>

locale sub_rel =
  fixes subs :: "'v sub_rel_t" (structure)

text \<open>We are only interested in subsumptions involving two different
occurrences of the same LTS
location. Moreover, once a vertex has been subsumed, there is no point in trying to subsume it again
by another subsumer: subsumees must have a unique subsumer. Finally, we do not allow chains of
subsumptions, thus the intersection of the sets of subsumers and subsumees must be empty. Such
subsumption relations are said to be \emph{well-formed}.\<close>

locale wf_sub_rel = sub_rel +
  assumes sub_imp_same_verts :
    "sub \<in> subs \<Longrightarrow> fst (subsumee sub) = fst (subsumer sub)"

  assumes subsumed_by_one :
    "\<forall> v \<in> subsumees subs. \<exists>! v'. (v,v') \<in> subs"

  assumes inter_empty :
    "subsumers subs \<inter> subsumees subs = {}"

begin
  lemmas wf_sub_rel = sub_imp_same_verts subsumed_by_one inter_empty

  text \<open>A rephrasing of the assumption @{term "subsumed_by_one"}.\<close>

  lemma (in wf_sub_rel) subsumed_by_two_imp :
    assumes "(v,v1) \<in> subs"
    assumes "(v,v2) \<in> subs"
    shows   "v1 = v2"
  using assms wf_sub_rel unfolding subsumees_conv by blast

  text \<open>A well-formed subsumption relation is equal to its transitive closure. We will see in the
  following one has to handle transitive closures of such relations.\<close>

  lemma in_trancl_imp :
    assumes "(v,v') \<in> subs\<^sup>+"
    shows   "(v,v') \<in> subs"
  using tranclD[OF assms] tranclD[of _ v' subs]
        rtranclD[of _ v' subs]
        inter_empty
  by force

  lemma trancl_eq :
    "subs\<^sup>+ = subs"
  using in_trancl_imp r_into_trancl[of _ _ subs] by fast
end

text \<open>The empty subsumption relation is well-formed.\<close>

lemma
  "wf_sub_rel {}"
by (auto simp add : wf_sub_rel_def)

subsubsection \<open>Subsumption relation of a graph\<close>

text \<open>We consider subsumption relations to equip rooted graphs. However, nothing in the previous
definitions relates these relations to graphs: subsumptions relations involve objects that are of
the type of indexed vertices, but that might to not be vertices of an actual graph. We equip
graphs with subsumption relations using the notion of \emph{sub-relation of a graph}. Such a
relation must only involve vertices of the graph it equips.\<close>

locale rgraph =
  fixes g :: "('v,'x) rgraph_scheme" (structure)

locale sub_rel_of = rgraph + sub_rel +
  assumes related_are_verts : "vertices subs \<subseteq> Graph.vertices g"
begin
  lemmas sub_rel_of = related_are_verts

  text \<open>The transitive closure of a sub-relation of a graph @{term "g"} is also a sub-relation of
  @{term "g"}.\<close>

  lemma trancl_sub_rel_of :
     "sub_rel_of g (subs\<^sup>+)"
  using tranclD[of _ _ subs] tranclD2[of _ _ subs] sub_rel_of
  unfolding sub_rel_of_def subsumers_conv subsumees_conv by blast
end

text \<open>The empty relation is a sub-relation of any graph.\<close>

lemma
  "sub_rel_of g {}"
by (auto simp add : sub_rel_of_def)

subsubsection \<open>Well-formed sub-relations\<close>

text \<open>We pack both previous locales into a third one. We speak about
\emph{well-formed sub-relations}.\<close>

locale wf_sub_rel_of = rgraph + sub_rel +
  assumes sub_rel_of : "sub_rel_of g subs"
  assumes wf_sub_rel : "wf_sub_rel subs"
begin
  lemmas wf_sub_rel_of = sub_rel_of wf_sub_rel
end

text \<open>The empty relation is a well-formed sub-relation of any graph.\<close>

lemma
  "wf_sub_rel_of g {}"
by (auto simp add : sub_rel_of_def wf_sub_rel_def wf_sub_rel_of_def)

text \<open>As previously, even if, in the end, we are only interested by well-formed sub-relations, we
assume the relation is such only when needed.\<close>

subsection \<open>Consistent Edge Sequences, Sub-paths\<close>

subsubsection \<open>Consistency in presence of a subsumption relation\<close>

text \<open>We model sub-paths in the same spirit than in \verb?Graph.thy?, by starting with
defining the consistency of a sequence of edges wrt.\ a subsumption relation. The idea is
that subsumption links can ``fill the gaps'' between subsequent edges that would have made
the sequence inconsistent otherwise. For now, we define consistency of a sequence wrt.\ any
subsumption relation. Thus, we cannot account yet for the fact that we only consider relations
without chains of subsumptions. The empty sequence is consistent wrt.\ to a subsumption relation
from @{term "v1"} to @{term "v2"} if these two vertices are equal or if they belong to the
transitive closure of the relation. A non-empty sequence is consistent if it is made of consistent
sequences whose extremities are linked in the transitive closure of the subsumption relation.\<close>

fun ces :: "('v \<times> nat) \<Rightarrow> ('v \<times> nat) edge list \<Rightarrow> ('v \<times> nat) \<Rightarrow> 'v sub_rel_t \<Rightarrow> bool" where
  "ces v1 [] v2 subs = (v1 = v2  \<or> (v1,v2) \<in> subs\<^sup>+)"
| "ces v1 (e#es) v2 subs = ((v1 = src e \<or> (v1,src e) \<in> subs\<^sup>+) \<and> ces (tgt e) es v2 subs)"

text \<open>A consistent sequence from @{term "v1"} to @{term "v2"} without a  subsumption relation is
consistent between these two vertices in presence of any relation.\<close>

lemma
  assumes "Graph.ces v1 es v2"
  shows   "ces v1 es v2 subs"
using assms by (induct es arbitrary : v1, auto)

text \<open>Consistency in presence of the empty subsumption relation reduces to consistency as defined
in \verb?Graph.thy?.\<close>

lemma
  assumes "ces v1 es v2 {}"
  shows   "Graph.ces v1 es v2"
using assms by (induct es arbitrary : v1, auto)

text \<open>Let @{term "(v1,v2)"} be an element of a subsumption relation, and @{term "es"} a sequence of
edges consistent wrt.\ this relation from vertex @{term "v2"}. Then @{term "es"} is also consistent
from @{term "v1"}. Even if this lemma will not be used much in the following, this is the base fact
for saying that paths feasible from a subsumee are also feasible from its subsumer.\<close>

lemma acas_imp_dcas :
  assumes "(v1,v2) \<in> subs"
  assumes "ces v2 es v subs"
  shows   "ces v1 es v subs"
using assms by (cases es, simp_all) (intro disjI2, force)+

text \<open>Let @{term "es"} be a sequence of edges consistent wrt. a subsumption relation. Extending
this relation preserves the consistency of @{term "es"}.\<close>

lemma ces_Un :
  assumes "ces v1 es v2  subs1"
  shows   "ces v1 es v2 (subs1 \<union> subs2)"
using assms by (induct es arbitrary : v1, auto simp add : trancl_mono)

text \<open>A rephrasing of the previous lemma.\<close>

lemma cas_subset :
  assumes "ces v1 es v2  subs1"
  assumes "subs1 \<subseteq> subs2"
  shows   "ces v1 es v2 subs2"
using assms by (induct es arbitrary : v1, auto simp add : trancl_mono)

text \<open>Simplification lemmas for @{term "ces"}.\<close>

lemma ces_append_one :
  "ces v1 (es @ [e]) v2 subs = (ces v1 es (src e) subs \<and> ces (src e) [e] v2 subs)"
by (induct es arbitrary : v1, auto)

lemma ces_append :
  "ces v1 (es1 @ es2) v2 subs = (\<exists> v. ces v1 es1 v subs \<and> ces v es2 v2 subs)"
proof (intro iffI, goal_cases)
  case 1 thus ?case
  by (induct es1 arbitrary : v1)
     (simp_all del : split_paired_Ex, blast)
next
  case 2 thus ?case
  proof (induct es1 arbitrary : v1)
    case (Nil v1)

    then obtain v where "ces v1 [] v subs"
                  and   "ces v es2 v2 subs"
    by blast

    thus ?case
    unfolding ces.simps
    proof (elim disjE, goal_cases)
      case 1 thus ?case by simp
    next
      case 2 thus ?case by (cases es2) (simp, intro disjI2, fastforce)+
    qed
  next
    case Cons thus ?case by auto
  qed
qed

text \<open>Let @{term "es"} be a sequence of edges consistent from @{term "v1"} to @{term "v2"} wrt.\ a
sub-relation @{term "subs"} of a graph @{term "g"}. Suppose elements of this sequence are edges of
@{term "g"}. If @{term "v1"} is a vertex of @{term "g"} then @{term "v2"} is also a vertex of
@{term "g"}.\<close>

subsubsection \<open>Sub-paths\<close>

text \<open>A sub-path leading from @{term "v1"} to @{term "v2"}, two vertices of a graph @{term "g"}
equipped with a subsumption relation @{term "subs"}, is a sequence of edges consistent wrt.\
@{term "subs"} from @{term "v1"} to @{term "v2"} whose elements are edges of @{term "g"}.
Moreover, we must assume that @{term "subs"} is a sub-relation of @{term "g"}, otherwise
@{term "es"} could ``exit'' @{term "g"} through subsumption links.\<close>

definition subpath ::
  "(('v \<times> nat),'x) rgraph_scheme \<Rightarrow> ('v \<times> nat) \<Rightarrow> ('v \<times> nat) edge list \<Rightarrow> ('v \<times> nat) \<Rightarrow> (('v \<times> nat) \<times> ('v \<times> nat)) set \<Rightarrow> bool"
where
  "subpath g v1 es v2 subs \<equiv> sub_rel_of g subs
                           \<and> v1 \<in> Graph.vertices g
                           \<and> ces v1 es v2 subs
                           \<and> set es \<subseteq> edges g"

text \<open>Once again, in some cases, we will not be interested in the ending vertex of a sub-path.\<close>

abbreviation subpath_from ::
  "(('v \<times> nat),'x) rgraph_scheme \<Rightarrow> ('v \<times> nat) \<Rightarrow> ('v \<times> nat) edge list \<Rightarrow> 'v sub_rel_t \<Rightarrow> bool"
where
  "subpath_from g v es subs \<equiv> \<exists> v'. subpath g v es v' subs"

text \<open>Simplification lemmas for @{term subpath}.\<close>

lemma Nil_sp :
  "subpath g v1 [] v2 subs \<longleftrightarrow> sub_rel_of g subs
                             \<and> v1 \<in> Graph.vertices g
                             \<and> (v1 = v2 \<or> (v1,v2) \<in> subs\<^sup>+)"
by (auto simp add : subpath_def)

text \<open>When the subsumption relation is well-formed (denoted by \<open>(in wf_sub_rel)\<close>),
there is no need to account for the transitive closure of the relation.\<close>

lemma (in wf_sub_rel) Nil_sp :
  "subpath g v1 [] v2 subs \<longleftrightarrow> sub_rel_of g subs
                             \<and> v1 \<in> Graph.vertices g
                             \<and> (v1 = v2 \<or> (v1,v2) \<in> subs)"
using trancl_eq by (simp add : Nil_sp)

text \<open>Simplification lemma for the one-element sequence.\<close>

lemma sp_one :
  shows   "subpath g v1 [e] v2 subs \<longleftrightarrow> sub_rel_of g subs
                                      \<and> (v1 = src e \<or> (v1,src e) \<in> subs\<^sup>+)
                                      \<and> e \<in> edges g
                                      \<and> (tgt e = v2 \<or> (tgt e,v2) \<in> subs\<^sup>+)"
using sub_rel_of.trancl_sub_rel_of[of g subs]
by (intro iffI, auto simp add : vertices_def sub_rel_of_def subpath_def)

text \<open>Once again, when the subsumption relation is well-formed, the previous lemma can be
simplified since, in this case, the transitive closure of the relation is the relation itself.\<close>

lemma (in wf_sub_rel_of) sp_one :
  shows "subpath g v1 [e] v2 subs \<longleftrightarrow> sub_rel_of g subs
                                    \<and> (v1 = src e \<or> (v1,src e) \<in> subs)
                                    \<and> e \<in> edges g
                                    \<and> (tgt e = v2 \<or> (tgt e,v2) \<in> subs)"
using sp_one wf_sub_rel.trancl_eq[OF wf_sub_rel] by fast

text \<open>Simplification lemma for the non-empty sequence (which might contain more than one element).\<close>

lemma sp_Cons :
  shows   "subpath g v1 (e # es) v2 subs \<longleftrightarrow> sub_rel_of g subs
                                           \<and> (v1 = src e  \<or> (v1,src e) \<in> subs\<^sup>+)
                                           \<and> e \<in> edges g
                                           \<and> subpath g (tgt e) es v2 subs"
using sub_rel_of.trancl_sub_rel_of[of g subs]
by (intro iffI, auto simp add : subpath_def vertices_def sub_rel_of_def)

text \<open>The same lemma when the subsumption relation is well-formed.\<close>

lemma (in wf_sub_rel_of) sp_Cons :
  "subpath g v1 (e # es) v2 subs \<longleftrightarrow> sub_rel_of g subs
                                   \<and> (v1 = src e \<or> (v1,src e) \<in> subs)
                                   \<and> e \<in> edges g
                                   \<and> subpath g (tgt e) es v2 subs"
using sp_Cons wf_sub_rel.trancl_eq[OF wf_sub_rel] by fast

text \<open>Simplification lemma for @{term "subpath"} when the sequence is known to end by a given
edge.\<close>

lemma sp_append_one :
  "subpath g v1 (es @ [e]) v2 subs \<longleftrightarrow> subpath g v1 es (src e) subs
                                     \<and> e \<in> edges g
                                     \<and> (tgt e = v2 \<or> (tgt e, v2) \<in> subs\<^sup>+)"
unfolding subpath_def by (auto simp add :  ces_append_one)

text \<open>Simpler version in the case of a well-formed subsumption relation.\<close>

lemma (in wf_sub_rel) sp_append_one :
  "subpath g v1 (es @ [e]) v2 subs \<longleftrightarrow> subpath g v1 es (src e) subs
                                     \<and> e \<in> edges g
                                     \<and> (tgt e = v2 \<or> (tgt e, v2) \<in> subs)"
using sp_append_one in_trancl_imp by fast

text \<open>Simplification lemma when the sequence is known to be the concatenation of two
sub-sequences.\<close>

lemma sp_append :
  "subpath g v1 (es1 @ es2) v2 subs \<longleftrightarrow>
   (\<exists> v. subpath g v1 es1 v subs \<and> subpath g v es2 v2 subs)"
proof (intro iffI, goal_cases)
  case 1 thus ?case
  using sub_rel_of.ces_imp_ends_vertices
  by (simp add : subpath_def ces_append) blast
next
  case 2 thus ?case
  unfolding subpath_def
  by (simp only : ces_append) fastforce
qed

text \<open>Let @{term "es"} be a sub-path of a graph @{term "g"} starting at vertex @{term "v1"}.
By definition of @{term "subpath"}, @{term "v1"} is a vertex of @{term "g"}. Even if this is a
direct consequence of the definition of @{term "subpath"}, this lemma will ease the proofs of some
goals in the following.\<close>

text \<open>The same property (which also follows the definition of @{term "subpath"}, but not as
trivially as the previous lemma) can be established for the final vertex @{term "v2"}.\<close>

lemma lst_of_sp_is_vert :
  assumes "subpath g v1 es v2 subs"
  shows   "v2 \<in> Graph.vertices g"
using assms sub_rel_of.trancl_sub_rel_of[of g subs]
by (induction es arbitrary : v1)
   (force simp add : subpath_def sub_rel_of_def, (simp add : sp_Cons, fast))

text \<open>A sub-path ending in a subsumed vertex can be extended to the subsumer of this vertex,
provided that the subsumption relation is a sub-relation of the graph it equips.\<close>

lemma sp_append_sub :
  assumes "subpath g v1 es v2 subs"
  assumes "(v2,v3) \<in> subs"
  shows   "subpath g v1 es v3 subs"
proof (cases es)
  case Nil

  moreover
  hence "v1 \<in> Graph.vertices g"
  and   "v1 = v2 \<or> (v1,v2) \<in> subs\<^sup>+"
  using assms(1) by (simp_all add : Nil_sp)

  ultimately
  show ?thesis
  using assms(1,2)
        Nil_sp[of g v1 v2 subs]
        trancl_into_trancl[of v1 v2 subs v3]
  by (auto simp add : subpath_def)
next
  case Cons

  then obtain es' e where "es = es' @ [e]" using neq_Nil_conv2[of es] by blast

  thus ?thesis using assms trancl_into_trancl by (simp add : sp_append_one) fast
qed

text \<open>Let @{term "g"} be a graph equipped with a well-formed sub-relation. A sub-path starting at
a subsumed vertex @{term "v1"} whose set of out-edges is empty is either:
\begin{enumerate}
  \item empty,
  \item a sub-path starting at the subsumer @{term "v2"} of @{term "v1"}.
\end{enumerate}
The third assumption represent the fact that, when building red-black graphs, we do not allow to
build the successor of a subsumed vertex.\<close>

lemma (in wf_sub_rel_of) sp_from_subsumee :
  assumes "(v1,v2) \<in> subs"
  assumes "subpath g v1 es v subs"
  assumes "out_edges g v1 = {}"
  shows   "es = [] \<or> subpath g v2 es v subs"
using assms
      wf_sub_rel.subsumed_by_two_imp[OF wf_sub_rel assms(1)]
by (cases es)
   (fast, (intro disjI2, fastforce simp add : sp_Cons))

text \<open>Note that it is not possible to split this lemma into two lemmas (one for each member of the
disjunctive conclusion). Suppose @{term "v"} is @{term "v1"}, then
@{term "es"} could be empty or it could also be a non-empty sub-path leading from @{term "v2"} to
@{term "v1"}. If @{term "v"} is not @{term "v1"}, it could be @{term "v2"} and @{term "es"} could
be empty or not.\<close>

text \<open>A sub-path starting at a non-subsumed vertex whose set of out-edges is empty is also empty.\<close>

lemma sp_from_de_empty :
  assumes "v1 \<notin> subsumees subs"
  assumes "out_edges g v1 = {}"
  assumes "subpath g v1 es v2 subs"
  shows   "es = []"
using assms tranclD by (cases es) (auto simp add : sp_Cons, force)

text \<open>Let @{term "e"} be an edge whose target is not subsumed and has not out-going edges. A
sub-path @{term "es"} containing @{term "e"} ends by @{term "e"} and this occurrence of @{term "e"}
is unique along @{term "es"}.\<close>

lemma sp_through_de_decomp :
  assumes "tgt e \<notin> subsumees subs"
  assumes "out_edges g (tgt e) = {}"
  assumes "subpath g v1 es v2 subs"
  assumes "e \<in> set es"
  shows   "\<exists> es'. es = es' @ [e] \<and> e \<notin> set es'"
using assms(3,4)
proof (induction es arbitrary : v1)
  case (Nil v1) thus ?case by simp
next
  case (Cons e' es v1)

  hence "subpath g (tgt e') es v2 subs"
  and  "e = e' \<or> (e \<noteq> e' \<and> e \<in> set es)" by (auto simp add : sp_Cons)

  thus ?case
  proof (elim disjE, goal_cases)
    case 1 thus ?case
    using sp_from_de_empty[OF assms(1,2)] by fastforce
  next
    case 2 thus ?case using Cons(1)[of "tgt e'"] by force
  qed
qed

text \<open>Consider a sub-path ending at the target of a recently added edge @{term "e"}, whose target
did not belong to the graph prior to its addition. If @{term "es"} starts in another vertex than
the target of @{term "e"}, then it contains @{term "e"}.\<close>

lemma (in sub_rel_of) sp_ends_in_tgt_imp_mem :
  assumes "tgt e \<notin> Graph.vertices g"
  assumes "v \<noteq> tgt e"
  assumes "subpath (add_edge g e) v es (tgt e) subs"
  shows   "e \<in> set es"
proof -
  have "tgt e \<notin> subsumers subs" using assms(1) sub_rel_of by auto

  hence "(v,tgt e) \<notin> subs\<^sup>+" using tranclD2 by force

  hence "es \<noteq> []" using assms(2,3) by (auto simp add : Nil_sp)

  then obtain es' e' where "es = es' @ [e']" by (simp add : neq_Nil_conv2) blast

  moreover
  hence "e' \<in> edges (add_edge g e)" using assms(3) by (auto simp add: subpath_def)

  moreover
  have "tgt e' = tgt e"
  using tranclD2 assms(3) \<open>tgt e \<notin> subsumers subs\<close> \<open>es = es' @ [e']\<close>
  by (force simp add : sp_append_one)

  ultimately
  show ?thesis using assms(1) unfolding vertices_def image_def by force
qed

end