(* Title:  Pair_Digraph.thy
   Author: Lars Noschinski, TU München
*)

theory Pair_Digraph
imports
  Digraph
  Bidirected_Digraph
  Arc_Walk
begin

section {* Digraphs without Parallel Arcs *}

text {*
  If no parallel arcs are desired, arcs can be accurately described as pairs of
  This is the natural representation for Digraphs without multi-arcs.
  and @{term "head G"}, making it easier to deal with multiple related graphs
  and to modify a graph by adding edges.

  This theory introduces such a specialisation of digraphs.
*}

record 'a pair_pre_digraph = pverts :: "'a set" parcs :: "'a rel"

definition with_proj :: "'a pair_pre_digraph \<Rightarrow> ('a, 'a \<times> 'a) pre_digraph" where
  "with_proj G = \<lparr> verts = pverts G, arcs = parcs G, tail = fst, head = snd \<rparr>"

declare [[coercion with_proj]]

primrec pawalk_verts :: "'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> 'a list" where
  "pawalk_verts u [] = [u]" |
  "pawalk_verts u (e # es) = fst e # pawalk_verts (snd e) es"

fun pcas :: "'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "pcas u [] v = (u = v)" |
  "pcas u (e # es) v = (fst e = u \<and> pcas (snd e) es v)"

lemma with_proj_simps[simp]:
  "verts (with_proj G) = pverts G"
  "arcs (with_proj G) = parcs G"
  "arcs_ends (with_proj G) = parcs G"
  "tail (with_proj G) = fst"
  "head (with_proj G) = snd"
  by (auto simp: with_proj_def arcs_ends_conv)

lemma cas_with_proj_eq: "pre_digraph.cas (with_proj G) = pcas"
proof (unfold fun_eq_iff, intro allI)
  fix u es v show "pre_digraph.cas (with_proj G) u es v = pcas u es v"
    by (induct es arbitrary: u) (auto simp:  pre_digraph.cas.simps)
qed

lemma awalk_verts_with_proj_eq: "pre_digraph.awalk_verts (with_proj G) = pawalk_verts"
proof (unfold fun_eq_iff, intro allI)
  fix u es show "pre_digraph.awalk_verts (with_proj G) u es = pawalk_verts u es"
    by (induct es arbitrary: u) (auto simp: pre_digraph.awalk_verts.simps)
qed

locale pair_pre_digraph = fixes G :: "'a pair_pre_digraph"
begin

lemmas [simp] = cas_with_proj_eq awalk_verts_with_proj_eq

end

locale pair_wf_digraph = pair_pre_digraph +
  assumes arc_fst_in_verts: "\<And>e. e \<in> parcs G \<Longrightarrow> fst e \<in> pverts G"
  assumes arc_snd_in_verts: "\<And>e. e \<in> parcs G \<Longrightarrow> snd e \<in> pverts G"
begin

lemma in_arcsD1: "(u,v) \<in> parcs G \<Longrightarrow> u \<in> pverts G"
  and in_arcsD2: "(u,v) \<in> parcs G \<Longrightarrow> v \<in> pverts G"
  by (auto dest: arc_fst_in_verts arc_snd_in_verts)

lemmas wellformed' = in_arcsD1 in_arcsD2

end

locale pair_fin_digraph = pair_wf_digraph +
  assumes pair_finite_verts: "finite (pverts G)"
    and pair_finite_arcs: "finite (parcs G)"

locale pair_sym_digraph = pair_wf_digraph +
  assumes pair_sym_arcs: "symmetric G"

locale pair_loopfree_digraph = pair_wf_digraph  +
  assumes pair_no_loops: "e \<in> parcs G \<Longrightarrow> fst e \<noteq> snd e"

locale pair_bidirected_digraph = pair_sym_digraph + pair_loopfree_digraph

locale pair_pseudo_graph = pair_fin_digraph + pair_sym_digraph

locale pair_digraph = pair_fin_digraph  + pair_loopfree_digraph

locale pair_graph = pair_digraph + pair_pseudo_graph

sublocale pair_pre_digraph \<subseteq> pre_digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales auto

sublocale pair_wf_digraph \<subseteq> wf_digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales (auto simp: arc_fst_in_verts arc_snd_in_verts)

sublocale pair_fin_digraph \<subseteq> fin_digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_finite_verts pair_finite_arcs by unfold_locales auto

sublocale pair_sym_digraph \<subseteq> sym_digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_sym_arcs by unfold_locales auto

sublocale pair_pseudo_graph \<subseteq> pseudo_graph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales auto

sublocale pair_loopfree_digraph \<subseteq> loopfree_digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  using pair_no_loops by unfold_locales auto

sublocale pair_digraph \<subseteq> digraph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales (auto simp: arc_to_ends_def)

sublocale pair_graph \<subseteq> graph "with_proj G"
  rewrites "verts G = pverts G" and "arcs G = parcs G" and "tail G = fst" and "head G = snd"
    and "arcs_ends G = parcs G"
    and "pre_digraph.awalk_verts G = pawalk_verts"
    and "pre_digraph.cas G = pcas"
  by unfold_locales auto

sublocale pair_graph \<subseteq> pair_bidirected_digraph by unfold_locales

lemma wf_digraph_wp_iff: "wf_digraph (with_proj G) = pair_wf_digraph G" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then interpret wf_digraph "with_proj G" .
  show ?R using wellformed by unfold_locales auto
next
  assume ?R then interpret pair_wf_digraph G .
  show ?L by unfold_locales
qed

lemma (in pair_fin_digraph) pair_fin_digraph[intro!]: "pair_fin_digraph G" ..

context pair_digraph begin

lemma pair_wf_digraph[intro!]: "pair_wf_digraph G" by intro_locales

lemma pair_digraph[intro!]: "pair_digraph G" ..

lemma (in pair_loopfree_digraph) no_loops':
  "(u,v) \<in> parcs G \<Longrightarrow> u \<noteq> v"
  by (auto dest: no_loops)

end

lemma (in pair_wf_digraph) apath_succ_decomp:
  assumes "apath u p v"
  assumes "(x,y) \<in> set p"
  assumes "y \<noteq> v"
  shows "\<exists>p1 z p2. p = p1 @ (x,y) # (y,z) # p2 \<and> x \<noteq> z \<and> y \<noteq> z"
proof -
  from `(x,y) \<in> set p` obtain p1 p2 where p_decomp: "p = p1 @ (x,y) # p2"
    by (metis (no_types) in_set_conv_decomp_first)
  from p_decomp `apath u p v` `y \<noteq> v` have "p2 \<noteq> []" "awalk y p2 v"
    by (auto simp: apath_def awalk_Cons_iff)
  then obtain z p2' where p2_decomp: "p2 = (y,z) # p2'"
    by atomize_elim (cases p2, auto simp: awalk_Cons_iff)
  then have "x \<noteq> z \<and> y \<noteq> z" using p_decomp p2_decomp `apath u p v`
    by (auto simp: apath_append_iff apath_simps hd_in_awalk_verts)
  with p_decomp p2_decomp have "p = p1 @ (x,y) # (y,z) # p2' \<and> x \<noteq> z \<and> y \<noteq> z"
    by auto
  then show ?thesis by blast
qed

lemma (in pair_sym_digraph) arcs_symmetric:
  "(a,b) \<in> parcs G \<Longrightarrow> (b,a) \<in> parcs G"
  using sym_arcs by (auto simp: symmetric_def elim: symE)

lemma (in pair_pseudo_graph) pair_pseudo_graph[intro]: "pair_pseudo_graph G" ..

lemma (in pair_graph) pair_graph[intro]: "pair_graph G" by unfold_locales
lemma (in pair_graph) pair_graphD_graph: "graph G" by unfold_locales

lemma pair_graphI_graph:
  assumes "graph (with_proj G)" shows "pair_graph G"
proof -
  interpret G: graph "with_proj G" by fact
  show ?thesis
    using G.wellformed G.finite_arcs G.finite_verts G.no_loops
    by unfold_locales auto
qed

lemma pair_loopfreeI_loopfree:
  assumes "loopfree_digraph (with_proj G)" shows "pair_loopfree_digraph G"
proof -
  interpret loopfree_digraph "with_proj G" by fact
  show ?thesis using wellformed no_loops by unfold_locales auto
qed

subsection {* Path reversal for Pair Digraphs *}

text {* This definition is only meaningful in @{term Pair_Digraph} *}

primrec rev_path :: "('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
  "rev_path [] = []" |
  "rev_path (e # es) = rev_path es @ [(snd e, fst e)]"

lemma rev_path_append[simp]: "rev_path (p @ q) = rev_path q @ rev_path p"
  by (induct p) auto

lemma rev_path_rev_path[simp]:
  "rev_path (rev_path p) = p"
  by (induct p) auto

lemma rev_path_empty[simp]:
  "rev_path p = [] \<longleftrightarrow> p = []"
  by (induct p) auto

lemma rev_path_eq: "rev_path p = rev_path q \<longleftrightarrow> p = q"
  by (metis rev_path_rev_path)

lemma (in pair_sym_digraph)
  assumes "awalk u p v"
  shows awalk_verts_rev_path: "awalk_verts v (rev_path p) = rev (awalk_verts u p)"
    and awalk_rev_path': "awalk v (rev_path p) u"
using assms
proof (induct p arbitrary: u)
  case Nil case 1 then show ?case by auto
next
  case Nil case 2 then show ?case by (auto simp: awalk_Nil_iff)
next
  case (Cons e es) case 1
  with Cons have walks: "awalk v (rev_path es) (snd e)"
        "awalk (snd e) [(snd e, fst e)] u"
      and verts: "awalk_verts v (rev_path es) = rev (awalk_verts (snd e) es)"
    by (auto simp: awalk_simps intro: arcs_symmetric)

  from walks have "awalk v (rev_path es @ [(snd e, fst e)]) u"
    by simp
  moreover
  have "tl (awalk_verts (awlast v (rev_path es)) [(snd e, fst e)]) = [fst e]"
    by auto
  ultimately
  show ?case using 1 verts by (auto simp: awalk_verts_append)
next
  case (Cons e es) case 2
  with Cons have "awalk v (rev_path es) (snd e)"
    by (auto simp: awalk_Cons_iff)
  moreover
  have "rev_path (e # es) = rev_path es @ [(snd e, fst e)]"
    by auto
  moreover
  from Cons 2 have "awalk (snd e) [(snd e, fst e)] u"
    by (auto simp: awalk_simps intro: arcs_symmetric)
  ultimately show "awalk v (rev_path (e # es)) u"
    by simp
qed

lemma (in pair_sym_digraph) awalk_rev_path[simp]:
  "awalk v (rev_path p) u = awalk u p v" (is "?L = ?R")
by (metis awalk_rev_path' rev_path_rev_path)

lemma (in pair_sym_digraph) apath_rev_path[simp]:
  "apath v (rev_path p) u = apath u p v"
by (auto simp: awalk_verts_rev_path apath_def)

subsection {* Subdividing Edges *}

text {* subdivide an edge (=two associated arcs) in graph *}
fun subdivide :: "'a pair_pre_digraph \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> 'a pair_pre_digraph" where
  "subdivide G (u,v) w = \<lparr>
    pverts = pverts G \<union> {w},
    parcs = (parcs G - {(u,v),(v,u)}) \<union> {(u,w), (w,u), (w, v), (v, w)}\<rparr>"

declare subdivide.simps[simp del]

text {* subdivide an arc in a path *}
fun sd_path :: "'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
    "sd_path _ _ [] = []"
  | "sd_path (u,v) w (e # es) = (if e = (u,v)
                                 then [(u,w),(w,v)]
                                 else if e = (v,u)
                                 then [(v,w),(w,u)]
                                 else [e]) @ sd_path (u,v) w es"

text {* contract an arc in a path  *}
fun co_path :: "'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk \<Rightarrow> ('a \<times> 'a) awalk" where
    "co_path _ _ [] = []"
  | "co_path _ _ [e] = [e]"
  | "co_path (u,v) w (e1 # e2 # es) = (if e1 = (u,w) \<and> e2 = (w,v)
      then (u,v) # co_path (u,v) w es
      else if e1 = (v,w) \<and> e2 = (w,u)
      then (v,u) # co_path (u,v) w es
      else e1 # co_path (u,v) w (e2 # es))"

lemma co_path_simps[simp]:
  "\<lbrakk>e1 \<noteq> (fst e, w); e1 \<noteq> (snd e,w)\<rbrakk> \<Longrightarrow> co_path e w (e1 # es) = e1 # co_path e w es"
  "\<lbrakk>e1 = (fst e, w); e2 = (w, snd e)\<rbrakk> \<Longrightarrow> co_path e w (e1 # e2 # es) = e # co_path e w es"
  "\<lbrakk>e1 = (snd e, w); e2 = (w, fst e)\<rbrakk>
    \<Longrightarrow> co_path e w (e1 # e2 # es) = (snd e, fst e) # co_path e w es"
  "\<lbrakk>e1 \<noteq> (fst e, w) \<or> e2 \<noteq> (w, snd e); e1 \<noteq> (snd e, w) \<or> e2 \<noteq> (w, fst e)\<rbrakk>
    \<Longrightarrow> co_path e w (e1 # e2 # es) = e1 # co_path e w (e2 # es)"
  apply (cases es; auto)
  apply (cases e; auto)
  apply (cases e; auto)
  apply (cases e; cases "fst e = snd e"; auto)
  apply (cases e; cases "fst e = snd e"; auto)
  done

lemma co_path_nonempty[simp]: "co_path e w p = [] \<longleftrightarrow> p = []"
  by (cases e) (cases p rule: list_exhaust_NSC, auto)

declare co_path.simps(3)[simp del]

lemma verts_subdivide[simp]: "pverts (subdivide G e w) = pverts G \<union> {w}"
  by (cases e) (auto simp: subdivide.simps)

lemma arcs_subdivide[simp]:
  shows "parcs (subdivide G (u,v) w) = (parcs G - {(u,v),(v,u)}) \<union> {(u,w), (w,u), (w, v), (v, w)}"
  by (auto simp: subdivide.simps)

lemmas subdivide_simps = verts_subdivide arcs_subdivide

lemma sd_path_induct[case_names empty pass sd sdrev]:
  assumes A: "P e []"
    and B: "\<And>e' es. e' \<noteq> e \<Longrightarrow> e' \<noteq> (snd e , fst e) \<Longrightarrow> P e es \<Longrightarrow> P e (e' # es)"
      "\<And>es. P e es \<Longrightarrow> P e (e # es)"
      "\<And>es. fst e \<noteq> snd e \<Longrightarrow> P e es \<Longrightarrow> P e ((snd e, fst e) # es)"
  shows "P e es"
  by (induct es) (rule A, metis B prod.collapse)

lemma co_path_induct[case_names empty single co corev pass]:
  fixes e :: "'a \<times> 'a"
    and w :: "'a"
    and p :: "('a \<times> 'a) awalk"
  assumes Nil: "P e w []"
    and ConsNil:"\<And>e'. P e w [e']"
    and ConsCons1: "\<And>e1 e2 es. e1 = (fst e, w) \<and> e2 = (w, snd e) \<Longrightarrow> P e w es \<Longrightarrow>
            P e w (e1 # e2 # es)"
    and ConsCons2: "\<And>e1 e2 es. \<not>(e1 = (fst e, w) \<and> e2 = (w, snd e)) \<and>
            e1 = (snd e, w) \<and> e2 = (w, fst e) \<Longrightarrow> P e w es \<Longrightarrow>
            P e w (e1 # e2 # es)"
    and ConsCons3: "\<And>e1 e2 es.
            \<not> (e1 = (fst e, w) \<and> e2 = (w, snd e)) \<Longrightarrow>
             \<not> (e1 = (snd e, w) \<and> e2 = (w, fst e)) \<Longrightarrow> P e w (e2 # es) \<Longrightarrow>
            P e w (e1 # e2 # es)"
  shows "P e w p"
proof (induct p rule: length_induct)
  case (1 p) then show ?case
  proof (cases p rule: list_exhaust_NSC)
    case (Cons_Cons e1 e2 es)
    then have "P e w es" "P e w (e2 # es)"using 1 by auto
    then show ?thesis unfolding Cons_Cons by (blast intro: ConsCons1 ConsCons2 ConsCons3)
  qed (auto intro: Nil ConsNil)
qed

lemma co_sd_id:
  assumes "(u,w) \<notin> set p" "(v,w) \<notin> set p"
  shows "co_path (u,v) w (sd_path (u,v) w p) = p"
using assms by (induct p) auto

lemma sd_path_id:
  assumes "(x,y) \<notin> set p" "(y,x) \<notin> set p"
  shows "sd_path (x,y) w p = p"
using assms by (induct p) auto

lemma (in pair_wf_digraph) pair_wf_digraph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_wf_digraph (subdivide G e w)" (is "pair_wf_digraph ?sG")
proof
  obtain u v where [simp]: "e = (u,v)" by (cases e) auto
  fix e' assume "e' \<in> parcs ?sG"
  then show "fst e' \<in> pverts ?sG" "snd e' \<in> pverts ?sG"
    using props by (auto dest: wellformed)
qed

lemma (in pair_sym_digraph) pair_sym_digraph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_sym_digraph (subdivide G e w)" (is "pair_sym_digraph ?sG")
proof -
  interpret sdG: pair_wf_digraph "subdivide G e w" using assms by (rule pair_wf_digraph_subdivide)
  obtain u v where [simp]: "e = (u,v)" by (cases e) auto
  show ?thesis
  proof
    have "\<And>a b. (a, b) \<in> parcs (subdivide G e w) \<Longrightarrow> (b, a) \<in> parcs (subdivide G e w)"
      unfolding `e = _` arcs_subdivide
      by (elim UnE, rule UnI1, rule_tac [2] UnI2) (blast intro: arcs_symmetric)+
    then show "symmetric ?sG"
      unfolding symmetric_def with_proj_simps by (rule symI)
  qed
qed

lemma (in pair_loopfree_digraph) pair_loopfree_digraph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_loopfree_digraph (subdivide G e w)" (is "pair_loopfree_digraph ?sG")
proof -
  interpret sdG: pair_wf_digraph "subdivide G e w" using assms by (rule pair_wf_digraph_subdivide)
  from assms show ?thesis
    by unfold_locales (cases e, auto dest: wellformed no_loops)
qed

lemma (in pair_bidirected_digraph) pair_bidirected_digraph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_bidirected_digraph (subdivide G e w)" (is "pair_bidirected_digraph ?sG")
proof -
  interpret sdG: pair_sym_digraph "subdivide G e w" using assms by (rule pair_sym_digraph_subdivide)
  interpret sdG: pair_loopfree_digraph "subdivide G e w" using assms by (rule pair_loopfree_digraph_subdivide)
  show ?thesis by unfold_locales
qed

lemma (in pair_pseudo_graph) pair_pseudo_graph_subdivide:
  assumes props: "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_pseudo_graph (subdivide G e w)" (is "pair_pseudo_graph ?sG")
proof -
  interpret sdG: pair_sym_digraph "subdivide G e w" using assms by (rule pair_sym_digraph_subdivide)
  obtain u v where [simp]: "e = (u,v)" by (cases e) auto
  show ?thesis by unfold_locales (cases e, auto)
qed

lemma (in pair_graph) pair_graph_subdivide:
  assumes "e \<in> parcs G" "w \<notin> pverts G"
  shows "pair_graph (subdivide G e w)" (is "pair_graph ?sG")
proof -
  interpret PPG: pair_pseudo_graph "subdivide G e w"
    using assms by (rule pair_pseudo_graph_subdivide)
  interpret PPG: pair_loopfree_digraph "subdivide G e w"
    using assms by (rule pair_loopfree_digraph_subdivide)
  from assms show ?thesis by unfold_locales
qed

lemma arcs_subdivideD:
  assumes "x \<in> parcs (subdivide G e w)" "fst x \<noteq> w" "snd x \<noteq> w"
  shows "x \<in> parcs G"
using assms by (cases e) auto

context pair_sym_digraph begin

lemma
  assumes path: "apath u p v"
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
  shows apath_sd_path: "pre_digraph.apath (subdivide G e w) u (sd_path e w p) v" (is ?A)
    and set_awalk_verts_sd_path: "set (awalk_verts u (sd_path e w p))
      \<subseteq> set (awalk_verts u p) \<union> {w}" (is ?B)
proof -
  obtain x y where e_conv: "e = (x,y)" by (cases e) auto
  def sG \<equiv> "subdivide G e w"
  interpret S: pair_sym_digraph sG
    unfolding sG_def using elems by (rule pair_sym_digraph_subdivide)

  have ev_sG: "S.awalk_verts = awalk_verts"
    by (auto simp: fun_eq_iff pre_digraph.awalk_verts_conv)
  have w_sG: "{(x,w), (y,w), (w,x), (w,y)} \<subseteq> parcs sG"
    by (auto simp: sG_def e_conv)

  from path have "S.apath u (sd_path (x,y) w p) v"
    and "set (S.awalk_verts u (sd_path (x,y) w p)) \<subseteq> set (awalk_verts u p) \<union> {w}"
  proof (induct p arbitrary: u rule: sd_path_induct)
    case empty case 1
    moreover have "pverts sG = pverts G \<union> {w}" by (simp add: sG_def)
    ultimately show ?case by (auto simp: apath_Nil_iff S.apath_Nil_iff)
  next
    case empty case 2 then show ?case by simp
  next
    case (pass e' es)
    { case 1
      then have "S.apath (snd e') (sd_path (x,y) w es) v" "u \<noteq> w" "fst e' = u"
          "u \<notin> set (S.awalk_verts (snd e') (sd_path (x,y) w es))"
        using pass elems by (fastforce simp: apath_Cons_iff)+
      moreover then have "e' \<in> parcs sG"
        using 1 pass by (auto simp: e_conv sG_def S.apath_Cons_iff apath_Cons_iff)
      ultimately show ?case using pass by (auto simp: S.apath_Cons_iff) }
    note case1 = this
    { case 2 with pass 2 show ?case by (simp add: apath_Cons_iff) blast }
  next
    { fix u es a b
      assume A: "apath u ((a,b) # es) v"
        and ab: "(a,b) = (x,y) \<or> (a,b) = (y,x)"
        and hyps: "\<And>u. apath u es v \<Longrightarrow> S.apath u (sd_path (x, y) w es) v"
          "\<And>u. apath u es v \<Longrightarrow> set (awalk_verts u (sd_path (x, y) w es)) \<subseteq> set (awalk_verts u es) \<union> {w}"

      from ab A have "(x,y) \<notin> set es" "(y,x) \<notin> set es"
        by (auto simp: apath_Cons_iff dest!: awalkI_apath dest: awalk_verts_arc1 awalk_verts_arc2)
      then have ev_sd: "set (S.awalk_verts b (sd_path (x,y) w es)) = set (awalk_verts b es)"
        by (simp add: sd_path_id)

      from A ab have [simp]: "x \<noteq> y"
        by (simp add: apath_Cons_iff) (metis awalkI_apath awalk_verts_non_Nil awhd_of_awalk hd_in_set)

      from A have "S.apath b (sd_path (x,y) w es) v" "u = a" "u \<noteq> w"
        using ab hyps elems by (auto simp: apath_Cons_iff wellformed')
      moreover
      then have "S.awalk u (sd_path (x, y) w ((a, b) # es)) v "
        using ab w_sG by (auto simp: S.apath_def S.awalk_simps S.wellformed')
      then have "u \<notin> set (S.awalk_verts w ((w,b) # sd_path (x,y) w es))"
        using ab `u \<noteq> w` ev_sd A by (auto simp: apath_Cons_iff S.awalk_def)
      moreover
      have "w \<notin> set (awalk_verts b (sd_path (x, y) w es))"
        using ab ev_sd A elems by (auto simp: awalk_Cons_iff apath_def)
      ultimately
      have path: "S.apath u (sd_path (x, y) w ((a, b) # es)) v "
        using ab hyps w_sG `u = a` by (auto simp: S.apath_Cons_iff ) }
    note path = this
    { case (sd es)
      { case 1 with sd show ?case by (intro path) auto }
      { case 2 show ?case using 2 sd
          by (auto simp: apath_Cons_iff) } }
    { case (sdrev es)
      { case 1 with sdrev show ?case by (intro path) auto }
      { case 2 show ?case using 2 sdrev
          by (auto simp: apath_Cons_iff) } }
  qed
  then show ?A ?B unfolding sG_def e_conv .
qed

lemma
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G" "u \<in> pverts G" "v \<in> pverts G"
  assumes path: "pre_digraph.apath (subdivide G e w) u p v"
  shows apath_co_path: "apath u (co_path e w p) v" (is ?thesis_path)
    and set_awalk_verts_co_path: "set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}" (is ?thesis_set)
proof -
  obtain x y where e_conv: "e = (x,y)" by (cases e) auto
  interpret S: pair_sym_digraph "subdivide G e w"
    using elems(1,2) by (rule pair_sym_digraph_subdivide)

  have e_w: "fst e \<noteq> w" "snd e \<noteq> w" using elems by auto

  have "S.apath u p v" "u \<noteq> w" using elems path by auto
  then have co_path: "apath u (co_path e w p) v
    \<and> set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}"
  proof (induction p arbitrary: u rule: co_path_induct)
    case empty with elems show ?case
      by (simp add: apath_Nil_iff S.apath_Nil_iff)
  next
    case (single e') with elems show ?case
     by (auto simp: apath_Cons_iff S.apath_Cons_iff apath_Nil_iff S.apath_Nil_iff
        dest: arcs_subdivideD)
  next
    case (co e1 e2 es)
    then have "apath u (co_path e w (e1 # e2 # es)) v" using co e_w elems
      by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using co e_w by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    ultimately
    show ?case by fast
  next
    case (corev e1 e2 es)
    have "apath u (co_path e w (e1 # e2 # es)) v" using corev(1-3) e_w(1) elems(1)
      by (auto simp: apath_Cons_iff S.apath_Cons_iff  intro: arcs_symmetric)
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using corev e_w by (auto simp: apath_Cons_iff S.apath_Cons_iff)
    ultimately
    show ?case by fast
  next
    case (pass e1 e2 es)
    have "fst e1 \<noteq> w" using elems pass.prems by (auto simp: S.apath_Cons_iff)
    have "snd e1 \<noteq> w"
    proof
      assume "snd e1 = w"
      then have "e1 \<notin> parcs G" using elems by auto
      then have "e1 \<in> parcs (subdivide G e w) - parcs G"
        using pass by (auto simp: S.apath_Cons_iff)
      then have "e1 = (x,w) \<or> e1 = (y,w)"
        using `fst e1 \<noteq> w` e_w by (auto simp add: e_conv)
      moreover
      have "fst e2 = w" using `snd e1 = w` pass.prems by (auto simp: S.apath_Cons_iff)
      then have "e2 \<notin> parcs G" using elems by auto
      then have "e2 \<in> parcs (subdivide G e w) - parcs G"
        using pass by (auto simp: S.apath_Cons_iff)
      then have "e2 = (w,x) \<or> e2 = (w,y)"
        using `fst e2 = w` e_w by (cases e2) (auto simp add: e_conv)
      ultimately
      have "e1 = (x,w) \<and> e2 = (w,x) \<or> e1 = (y,w) \<and> e2 = (w,y)"
        using pass.hyps[simplified e_conv] by auto
      then show False
        using pass.prems by (cases es) (auto simp: S.apath_Cons_iff)
    qed
    then have "e1 \<in> parcs G"
      using `fst e1 \<noteq> w` pass.prems by (auto simp: S.apath_Cons_iff dest: arcs_subdivideD)

    have ih: "apath (snd e1) (co_path e w (e2 # es)) v \<and> set (awalk_verts (snd e1) (co_path e w (e2 # es))) = set (awalk_verts (snd e1) (e2 # es)) - {w}"
      using pass.prems `snd e1 \<noteq> w` by (intro pass.IH) (auto simp: apath_Cons_iff S.apath_Cons_iff)
    then have "fst e1 \<notin> set (awalk_verts (snd e1) (co_path e w (e2 # es)))" "fst e1 = u"
      using pass.prems by (clarsimp simp: S.apath_Cons_iff)+
    then have "apath u (co_path e w (e1 # e2 # es)) v"
      using ih pass `e1 \<in> parcs G` by (auto simp: apath_Cons_iff S.apath_Cons_iff)[]
    moreover
    have "set (awalk_verts u (co_path e w (e1 # e2 # es))) = set (awalk_verts u (e1 # e2 # es)) - {w}"
      using pass.hyps ih `fst e1 \<noteq> w` by auto
    ultimately show ?case by fast
  qed
  then show ?thesis_set ?thesis_path by blast+
qed

end

subsection \<open>Bidirected Graphs\<close>

definition (in -) swap_in :: "('a \<times> 'a) set \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "swap_in S x = (if x \<in> S then prod.swap x else x)"

lemma bidirected_digraph_rev_conv_pair:
  assumes "bidirected_digraph (with_proj G) rev_G"
  shows "rev_G = swap_in (parcs G)"
proof -
  interpret bidirected_digraph G rev_G by fact
  have "\<And>a b. (a, b) \<in> parcs G \<Longrightarrow> rev_G (a, b) = (b, a)"
    using tail_arev[simplified with_proj_simps] head_arev[simplified with_proj_simps]
    by (metis fst_conv prod.collapse snd_conv)
  then show ?thesis by (auto simp: swap_in_def fun_eq_iff arev_eq)
qed

lemma (in pair_bidirected_digraph) bidirected_digraph:
  "bidirected_digraph (with_proj G) (swap_in (parcs G))"
  using no_loops' arcs_symmetric
  by unfold_locales (auto simp: swap_in_def)

lemma pair_bidirected_digraphI_bidirected_digraph:
  assumes "bidirected_digraph (with_proj G) (swap_in (parcs G))"
  shows "pair_bidirected_digraph G"
proof -
  interpret bidirected_digraph "with_proj G" "swap_in (parcs G)" by fact
  {
    fix a assume "a \<in> parcs G" then have "fst a \<noteq> snd a"
      using arev_neq[of a] bidirected_digraph_rev_conv_pair[OF assms(1)]
      by (cases a) (auto simp: swap_in_def)
  }
  then show ?thesis
    using tail_in_verts head_in_verts by unfold_locales auto
qed

end


theory examples
imports Main   "quantum_hoare_logic" "lt"
begin

lemma grover:  "valid I
               (((Init 2 0;Init 2 1;Init 2 2;Init 4 3;
               Utrans Delta 2;Utrans H 0;Utrans H 1;Utrans H 2);
              While M0 M1 (Utrans Or (10);Utrans H 0;Utrans H 1;Utrans Ph 10;
         Utrans H 0; Utrans H 1) Q);
           Cond [(N0,SKIP,P),(N1,SKIP,P),(N2,SKIP,P),(N3,SKIP,P)] )
               P"
apply(rule_tac Q="sum1 [(N0,SKIP,P),(N1,SKIP,P),(N2,SKIP,P),(N3,SKIP,P)]" in Seq)
prefer 2
apply(rule  Measure)
apply quantum_oracle
apply (simp add:Skip)+
apply(rule_tac Q="(mat_add (uu M0   (mat_add (mat_mult (mat_mult (dag N0) P) N0)
       (mat_add (mat_mult (mat_mult (dag N1) P) N1) (mat_add (mat_mult (mat_mult (dag N2) P) N2) (mat_mult (mat_mult (dag N3) P) N3))))) (uu M1 Q))" in Seq)
prefer 2
apply(rule While)
apply quantum_oracle
apply(vcg,auto)
prefer 7
apply(vcg,auto)
apply quantum_oracle+
done
(*
lemma shor:"valid P  (Init 2 0;Utrans H 0;Utrans U 1;Utrans (dag U) 1;Utrans (dag H) 0;
                    Cond [(M0,SKIP,Q),(M1,SKIP,Q)])   Q"
apply(rule ord_wlp,auto)
apply quantum_oracle+
apply (metis fst_conv fsts.cases snd_conv snds.cases wellDefined.simps(1))
apply (metis fst_conv fsts.cases snd_conv snds.cases wellDefined.simps(1))
apply quantum_oracle
done*)
end


(*  Title:      HOL/ex/SAT_Examples.thy
    Author:     Alwen Tiu, Tjark Weber
    Copyright   2005-2009
*)

section \<open>Examples for proof methods "sat" and "satx"\<close>

theory SAT_Examples
imports MainRLT
begin

(*
declare [[sat_solver = zchaff_with_proofs]]
declare [[sat_solver = minisat_with_proofs]]
declare [[sat_trace]]
*)

lemma "True"
by sat

lemma "a | ~a"
by sat

lemma "(a | b) & ~a \<Longrightarrow> b"
by sat

lemma "(a & b) | (c & d) \<Longrightarrow> (a & b) | (c & d)"
(*
apply (tactic {* CNF.cnf_rewrite_tac @{context} 1 *})
*)
by sat

lemma "(a & b) | (c & d) \<Longrightarrow> (a & b) | (c & d)"
(*
apply (tactic {* CNF.cnfx_rewrite_tac @{context} 1 *})
apply (erule exE | erule conjE)+
*)
by satx

lemma "(a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)
  \<Longrightarrow> (a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)"
(*
apply (tactic {* CNF.cnf_rewrite_tac @{context} 1 *})
*)
by sat

lemma "(a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)
  \<Longrightarrow> (a & b | c & d) & (e & f | g & h) | (i & j | k & l) & (m & n | p & q)"
(*
apply (tactic {* CNF.cnfx_rewrite_tac @{context} 1 *})
apply (erule exE | erule conjE)+
*)
by satx

lemma "P=P=P=P=P=P=P=P=P=P"
by sat

lemma "P=P=P=P=P=P=P=P=P=P"
by satx

lemma  "!! a b c. [| a | b | c | d ;
e | f | (a & d) ;
~(a | (c & ~c)) | b ;
~(b & (x | ~x)) | c ;
~(d | False) | c ;
~(c | (~p & (p | (q & ~q)))) |] ==> False"
by sat

lemma  "!! a b c. [| a | b | c | d ;
e | f | (a & d) ;
~(a | (c & ~c)) | b ;
~(b & (x | ~x)) | c ;
~(d | False) | c ;
~(c | (~p & (p | (q & ~q)))) |] ==> False"
by satx

text \<open>eta-Equivalence\<close>

lemma "(\<forall>x. P x) \<or> \<not> All P"
by sat

declare [[sat_trace = false]]
declare [[quick_and_dirty = false]]

method_setup rawsat = \<open>
  Scan.succeed (SIMPLE_METHOD' o SAT.rawsat_tac)
\<close> "SAT solver (no preprocessing)"

(* Translated from TPTP problem library: PUZ015-2.006.dimacs *)

lemma assumes 1: "~x0"
and 2: "~x30"
and 3: "~x29"
and 4: "~x59"
and 5: "x1 | x31 | x0"
and 6: "x2 | x32 | x1"
and 7: "x3 | x33 | x2"
and 8: "x4 | x34 | x3"
and 9: "x35 | x4"
and 10: "x5 | x36 | x30"
and 11: "x6 | x37 | x5 | x31"
and 12: "x7 | x38 | x6 | x32"
and 13: "x8 | x39 | x7 | x33"
and 14: "x9 | x40 | x8 | x34"
and 15: "x41 | x9 | x35"
and 16: "x10 | x42 | x36"
and 17: "x11 | x43 | x10 | x37"
and 18: "x12 | x44 | x11 | x38"
and 19: "x13 | x45 | x12 | x39"
and 20: "x14 | x46 | x13 | x40"
and 21: "x47 | x14 | x41"
and 22: "x15 | x48 | x42"
and 23: "x16 | x49 | x15 | x43"
and 24: "x17 | x50 | x16 | x44"
and 25: "x18 | x51 | x17 | x45"
and 26: "x19 | x52 | x18 | x46"
and 27: "x53 | x19 | x47"
and 28: "x20 | x54 | x48"
and 29: "x21 | x55 | x20 | x49"
and 30: "x22 | x56 | x21 | x50"
and 31: "x23 | x57 | x22 | x51"
and 32: "x24 | x58 | x23 | x52"
and 33: "x59 | x24 | x53"
and 34: "x25 | x54"
and 35: "x26 | x25 | x55"
and 36: "x27 | x26 | x56"
and 37: "x28 | x27 | x57"
and 38: "x29 | x28 | x58"
and 39: "~x1 | ~x31"
and 40: "~x1 | ~x0"
and 41: "~x31 | ~x0"
and 42: "~x2 | ~x32"
and 43: "~x2 | ~x1"
and 44: "~x32 | ~x1"
and 45: "~x3 | ~x33"
and 46: "~x3 | ~x2"
and 47: "~x33 | ~x2"
and 48: "~x4 | ~x34"
and 49: "~x4 | ~x3"
and 50: "~x34 | ~x3"
and 51: "~x35 | ~x4"
and 52: "~x5 | ~x36"
and 53: "~x5 | ~x30"
and 54: "~x36 | ~x30"
and 55: "~x6 | ~x37"
and 56: "~x6 | ~x5"
and 57: "~x6 | ~x31"
and 58: "~x37 | ~x5"
and 59: "~x37 | ~x31"
and 60: "~x5 | ~x31"
and 61: "~x7 | ~x38"
and 62: "~x7 | ~x6"
and 63: "~x7 | ~x32"
and 64: "~x38 | ~x6"
and 65: "~x38 | ~x32"
and 66: "~x6 | ~x32"
and 67: "~x8 | ~x39"
and 68: "~x8 | ~x7"
and 69: "~x8 | ~x33"
and 70: "~x39 | ~x7"
and 71: "~x39 | ~x33"
and 72: "~x7 | ~x33"
and 73: "~x9 | ~x40"
and 74: "~x9 | ~x8"
and 75: "~x9 | ~x34"
and 76: "~x40 | ~x8"
and 77: "~x40 | ~x34"
and 78: "~x8 | ~x34"
and 79: "~x41 | ~x9"
and 80: "~x41 | ~x35"
and 81: "~x9 | ~x35"
and 82: "~x10 | ~x42"
and 83: "~x10 | ~x36"
and 84: "~x42 | ~x36"
and 85: "~x11 | ~x43"
and 86: "~x11 | ~x10"
and 87: "~x11 | ~x37"
and 88: "~x43 | ~x10"
and 89: "~x43 | ~x37"
and 90: "~x10 | ~x37"
and 91: "~x12 | ~x44"
and 92: "~x12 | ~x11"
and 93: "~x12 | ~x38"
and 94: "~x44 | ~x11"
and 95: "~x44 | ~x38"
and 96: "~x11 | ~x38"
and 97: "~x13 | ~x45"
and 98: "~x13 | ~x12"
and 99: "~x13 | ~x39"
and 100: "~x45 | ~x12"
and 101: "~x45 | ~x39"
and 102: "~x12 | ~x39"
and 103: "~x14 | ~x46"
and 104: "~x14 | ~x13"
and 105: "~x14 | ~x40"
and 106: "~x46 | ~x13"
and 107: "~x46 | ~x40"
and 108: "~x13 | ~x40"
and 109: "~x47 | ~x14"
and 110: "~x47 | ~x41"
and 111: "~x14 | ~x41"
and 112: "~x15 | ~x48"
and 113: "~x15 | ~x42"
and 114: "~x48 | ~x42"
and 115: "~x16 | ~x49"
and 116: "~x16 | ~x15"
and 117: "~x16 | ~x43"
and 118: "~x49 | ~x15"
and 119: "~x49 | ~x43"
and 120: "~x15 | ~x43"
and 121: "~x17 | ~x50"
and 122: "~x17 | ~x16"
and 123: "~x17 | ~x44"
and 124: "~x50 | ~x16"
and 125: "~x50 | ~x44"
and 126: "~x16 | ~x44"
and 127: "~x18 | ~x51"
and 128: "~x18 | ~x17"
and 129: "~x18 | ~x45"
and 130: "~x51 | ~x17"
and 131: "~x51 | ~x45"
and 132: "~x17 | ~x45"
and 133: "~x19 | ~x52"
and 134: "~x19 | ~x18"
and 135: "~x19 | ~x46"
and 136: "~x52 | ~x18"
and 137: "~x52 | ~x46"
and 138: "~x18 | ~x46"
and 139: "~x53 | ~x19"
and 140: "~x53 | ~x47"
and 141: "~x19 | ~x47"
and 142: "~x20 | ~x54"
and 143: "~x20 | ~x48"
and 144: "~x54 | ~x48"
and 145: "~x21 | ~x55"
and 146: "~x21 | ~x20"
and 147: "~x21 | ~x49"
and 148: "~x55 | ~x20"
and 149: "~x55 | ~x49"
and 150: "~x20 | ~x49"
and 151: "~x22 | ~x56"
and 152: "~x22 | ~x21"
and 153: "~x22 | ~x50"
and 154: "~x56 | ~x21"
and 155: "~x56 | ~x50"
and 156: "~x21 | ~x50"
and 157: "~x23 | ~x57"
and 158: "~x23 | ~x22"
and 159: "~x23 | ~x51"
and 160: "~x57 | ~x22"
and 161: "~x57 | ~x51"
and 162: "~x22 | ~x51"
and 163: "~x24 | ~x58"
and 164: "~x24 | ~x23"
and 165: "~x24 | ~x52"
and 166: "~x58 | ~x23"
and 167: "~x58 | ~x52"
and 168: "~x23 | ~x52"
and 169: "~x59 | ~x24"
and 170: "~x59 | ~x53"
and 171: "~x24 | ~x53"
and 172: "~x25 | ~x54"
and 173: "~x26 | ~x25"
and 174: "~x26 | ~x55"
and 175: "~x25 | ~x55"
and 176: "~x27 | ~x26"
and 177: "~x27 | ~x56"
and 178: "~x26 | ~x56"
and 179: "~x28 | ~x27"
and 180: "~x28 | ~x57"
and 181: "~x27 | ~x57"
and 182: "~x29 | ~x28"
and 183: "~x29 | ~x58"
and 184: "~x28 | ~x58"
shows "False"
using assms
(*
by sat
*)
by rawsat  \<comment> \<open>this is without CNF conversion\<close>

(* Translated from TPTP problem library: MSC007-1.008.dimacs *)

lemma assumes 1: "x0 | x1 | x2 | x3 | x4 | x5 | x6"
and 2: "x7 | x8 | x9 | x10 | x11 | x12 | x13"
and 3: "x14 | x15 | x16 | x17 | x18 | x19 | x20"
and 4: "x21 | x22 | x23 | x24 | x25 | x26 | x27"
and 5: "x28 | x29 | x30 | x31 | x32 | x33 | x34"
and 6: "x35 | x36 | x37 | x38 | x39 | x40 | x41"
and 7: "x42 | x43 | x44 | x45 | x46 | x47 | x48"
and 8: "x49 | x50 | x51 | x52 | x53 | x54 | x55"
and 9: "~x0 | ~x7"
and 10: "~x0 | ~x14"
and 11: "~x0 | ~x21"
and 12: "~x0 | ~x28"
and 13: "~x0 | ~x35"
and 14: "~x0 | ~x42"
and 15: "~x0 | ~x49"
and 16: "~x7 | ~x14"
and 17: "~x7 | ~x21"
and 18: "~x7 | ~x28"
and 19: "~x7 | ~x35"
and 20: "~x7 | ~x42"
and 21: "~x7 | ~x49"
and 22: "~x14 | ~x21"
and 23: "~x14 | ~x28"
and 24: "~x14 | ~x35"
and 25: "~x14 | ~x42"
and 26: "~x14 | ~x49"
and 27: "~x21 | ~x28"
and 28: "~x21 | ~x35"
and 29: "~x21 | ~x42"
and 30: "~x21 | ~x49"
and 31: "~x28 | ~x35"
and 32: "~x28 | ~x42"
and 33: "~x28 | ~x49"
and 34: "~x35 | ~x42"
and 35: "~x35 | ~x49"
and 36: "~x42 | ~x49"
and 37: "~x1 | ~x8"
and 38: "~x1 | ~x15"
and 39: "~x1 | ~x22"
and 40: "~x1 | ~x29"
and 41: "~x1 | ~x36"
and 42: "~x1 | ~x43"
and 43: "~x1 | ~x50"
and 44: "~x8 | ~x15"
and 45: "~x8 | ~x22"
and 46: "~x8 | ~x29"
and 47: "~x8 | ~x36"
and 48: "~x8 | ~x43"
and 49: "~x8 | ~x50"
and 50: "~x15 | ~x22"
and 51: "~x15 | ~x29"
and 52: "~x15 | ~x36"
and 53: "~x15 | ~x43"
and 54: "~x15 | ~x50"
and 55: "~x22 | ~x29"
and 56: "~x22 | ~x36"
and 57: "~x22 | ~x43"
and 58: "~x22 | ~x50"
and 59: "~x29 | ~x36"
and 60: "~x29 | ~x43"
and 61: "~x29 | ~x50"
and 62: "~x36 | ~x43"
and 63: "~x36 | ~x50"
and 64: "~x43 | ~x50"
and 65: "~x2 | ~x9"
and 66: "~x2 | ~x16"
and 67: "~x2 | ~x23"
and 68: "~x2 | ~x30"
and 69: "~x2 | ~x37"
and 70: "~x2 | ~x44"
and 71: "~x2 | ~x51"
and 72: "~x9 | ~x16"
and 73: "~x9 | ~x23"
and 74: "~x9 | ~x30"
and 75: "~x9 | ~x37"
and 76: "~x9 | ~x44"
and 77: "~x9 | ~x51"
and 78: "~x16 | ~x23"
and 79: "~x16 | ~x30"
and 80: "~x16 | ~x37"
and 81: "~x16 | ~x44"
and 82: "~x16 | ~x51"
and 83: "~x23 | ~x30"
and 84: "~x23 | ~x37"
and 85: "~x23 | ~x44"
and 86: "~x23 | ~x51"
and 87: "~x30 | ~x37"
and 88: "~x30 | ~x44"
and 89: "~x30 | ~x51"
and 90: "~x37 | ~x44"
and 91: "~x37 | ~x51"
and 92: "~x44 | ~x51"
and 93: "~x3 | ~x10"
and 94: "~x3 | ~x17"
and 95: "~x3 | ~x24"
and 96: "~x3 | ~x31"
and 97: "~x3 | ~x38"
and 98: "~x3 | ~x45"
and 99: "~x3 | ~x52"
and 100: "~x10 | ~x17"
and 101: "~x10 | ~x24"
and 102: "~x10 | ~x31"
and 103: "~x10 | ~x38"
and 104: "~x10 | ~x45"
and 105: "~x10 | ~x52"
and 106: "~x17 | ~x24"
and 107: "~x17 | ~x31"
and 108: "~x17 | ~x38"
and 109: "~x17 | ~x45"
and 110: "~x17 | ~x52"
and 111: "~x24 | ~x31"
and 112: "~x24 | ~x38"
and 113: "~x24 | ~x45"
and 114: "~x24 | ~x52"
and 115: "~x31 | ~x38"
and 116: "~x31 | ~x45"
and 117: "~x31 | ~x52"
and 118: "~x38 | ~x45"
and 119: "~x38 | ~x52"
and 120: "~x45 | ~x52"
and 121: "~x4 | ~x11"
and 122: "~x4 | ~x18"
and 123: "~x4 | ~x25"
and 124: "~x4 | ~x32"
and 125: "~x4 | ~x39"
and 126: "~x4 | ~x46"
and 127: "~x4 | ~x53"
and 128: "~x11 | ~x18"
and 129: "~x11 | ~x25"
and 130: "~x11 | ~x32"
and 131: "~x11 | ~x39"
and 132: "~x11 | ~x46"
and 133: "~x11 | ~x53"
and 134: "~x18 | ~x25"
and 135: "~x18 | ~x32"
and 136: "~x18 | ~x39"
and 137: "~x18 | ~x46"
and 138: "~x18 | ~x53"
and 139: "~x25 | ~x32"
and 140: "~x25 | ~x39"
and 141: "~x25 | ~x46"
and 142: "~x25 | ~x53"
and 143: "~x32 | ~x39"
and 144: "~x32 | ~x46"
and 145: "~x32 | ~x53"
and 146: "~x39 | ~x46"
and 147: "~x39 | ~x53"
and 148: "~x46 | ~x53"
and 149: "~x5 | ~x12"
and 150: "~x5 | ~x19"
and 151: "~x5 | ~x26"
and 152: "~x5 | ~x33"
and 153: "~x5 | ~x40"
and 154: "~x5 | ~x47"
and 155: "~x5 | ~x54"
and 156: "~x12 | ~x19"
and 157: "~x12 | ~x26"
and 158: "~x12 | ~x33"
and 159: "~x12 | ~x40"
and 160: "~x12 | ~x47"
and 161: "~x12 | ~x54"
and 162: "~x19 | ~x26"
and 163: "~x19 | ~x33"
and 164: "~x19 | ~x40"
and 165: "~x19 | ~x47"
and 166: "~x19 | ~x54"
and 167: "~x26 | ~x33"
and 168: "~x26 | ~x40"
and 169: "~x26 | ~x47"
and 170: "~x26 | ~x54"
and 171: "~x33 | ~x40"
and 172: "~x33 | ~x47"
and 173: "~x33 | ~x54"
and 174: "~x40 | ~x47"
and 175: "~x40 | ~x54"
and 176: "~x47 | ~x54"
and 177: "~x6 | ~x13"
and 178: "~x6 | ~x20"
and 179: "~x6 | ~x27"
and 180: "~x6 | ~x34"
and 181: "~x6 | ~x41"
and 182: "~x6 | ~x48"
and 183: "~x6 | ~x55"
and 184: "~x13 | ~x20"
and 185: "~x13 | ~x27"
and 186: "~x13 | ~x34"
and 187: "~x13 | ~x41"
and 188: "~x13 | ~x48"
and 189: "~x13 | ~x55"
and 190: "~x20 | ~x27"
and 191: "~x20 | ~x34"
and 192: "~x20 | ~x41"
and 193: "~x20 | ~x48"
and 194: "~x20 | ~x55"
and 195: "~x27 | ~x34"
and 196: "~x27 | ~x41"
and 197: "~x27 | ~x48"
and 198: "~x27 | ~x55"
and 199: "~x34 | ~x41"
and 200: "~x34 | ~x48"
and 201: "~x34 | ~x55"
and 202: "~x41 | ~x48"
and 203: "~x41 | ~x55"
and 204: "~x48 | ~x55"
shows "False"
using assms
(*
by sat
*)
by rawsat  \<comment> \<open>this is without CNF conversion\<close>

(* Old sequent clause representation ("[c_i, p, ~q, \<dots>] \<turnstile> False"):
   sat, zchaff_with_proofs: 8705 resolution steps in
                            +++ User 1.154  All 1.189 secs
   sat, minisat_with_proofs: 40790 resolution steps in
                             +++ User 3.762  All 3.806 secs

   rawsat, zchaff_with_proofs: 8705 resolution steps in
                               +++ User 0.731  All 0.751 secs
   rawsat, minisat_with_proofs: 40790 resolution steps in
                                +++ User 3.514  All 3.550 secs

   CNF clause representation ("[c_1 && \<dots> && c_n, p, ~q, \<dots>] \<turnstile> False"):
   rawsat, zchaff_with_proofs: 8705 resolution steps in
                               +++ User 0.653  All 0.670 secs
   rawsat, minisat_with_proofs: 40790 resolution steps in
                                +++ User 1.860  All 1.886 secs

   (as of 2006-08-30, on a 2.5 GHz Pentium 4)
*)

text \<open>
Function {\tt benchmark} takes the name of an existing DIMACS CNF
file, parses this file, passes the problem to a SAT solver, and checks
the proof of unsatisfiability found by the solver.  The function
measures the time spent on proof reconstruction (at least real time
also includes time spent in the SAT solver), and additionally returns
the number of resolution steps in the proof.
\<close>

(*
declare [[sat_solver = zchaff_with_proofs]]
declare [[sat_trace = false]]
declare [[quick_and_dirty = false]]
*)
ML \<open>
  fun benchmark dimacsfile =
    let
      val prop_fm = SAT_Solver.read_dimacs_cnf_file (Path.explode dimacsfile)
      fun and_to_list (Prop_Logic.And (fm1, fm2)) acc = and_to_list fm2 (fm1 :: acc)
        | and_to_list fm acc = rev (fm :: acc)
      val clauses = and_to_list prop_fm []
      val terms = map (HOLogic.mk_Trueprop o Prop_Logic.term_of_prop_formula) clauses
      val cterms = map (Thm.cterm_of \<^context>) terms
      val start = Timing.start ()
      val _ = SAT.rawsat_thm \<^context> cterms
    in
      (Timing.result start, ! SAT.counter)
    end;
\<close>

end


theory AssocList
  imports Utils Environment
begin

fun remove_first :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'b) list" where
  "remove_first [] a' = []"
| "remove_first ((a, b) # ab) a' = (if a = a' then ab else (a, b) # remove_first ab a')"

fun remove_all :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'b) list" where
  "remove_all [] a' = []"
| "remove_all ((a, b) # ab) a' = (if a = a' then remove_all ab a' else (a, b) # remove_all ab a')"

primrec listify :: "('a \<times> 'b) list \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "listify ab [] = []"
| "listify ab (a # as) = the (map_of ab a) # listify (remove_first ab a) as"

lemma [simp]: "a \<noteq> b \<Longrightarrow> map_of (remove_first as b) a = map_of as a"
  by (induction as b rule: remove_first.induct) simp_all

lemma [simp]: "listify ((a, b) # ab) (insert_at 0 a as) = insert_at 0 b (listify ab as)"
  by (induction as) simp_all

lemma [simp]: "mset (map fst ab) = mset as \<Longrightarrow> idx_of as a = Some x \<Longrightarrow>
  lookup (listify ab as) x = map_of ab a"
proof (induction as arbitrary: ab x)
  case (Cons a' as)
  thus ?case
  proof (induction x)
    case 0
    moreover hence "a' = a \<or> (a' \<noteq> a \<and> map_option Suc (idx_of as a) = Some 0)" by fastforce
    ultimately show ?case by simp
  next
    case (Suc x)
    moreover hence "a' \<noteq> a" by fastforce
    moreover with Suc have "idx_of as a = Some x" by fastforce
    moreover from Suc have "mset (map fst (remove_first ab a')) = mset as" by simp
    ultimately show ?case by fastforce
  qed
qed simp_all

lemma [simp]: "map_of ab a = Some b \<Longrightarrow> mset (map fst ab) = mset as \<Longrightarrow> idx_of as a \<noteq> None"
proof (induction ab arbitrary: as)
  case (Cons a' ab)
  thus ?case
  proof (induction a')
    case (Pair a' b')
    thus ?case
    proof (induction as)
      case (Cons a'' as)
      thus ?case
      proof (cases "a = a''")
        case False note F'' = False
        thus ?thesis
        proof (cases "a = a'")
          case True
          from Cons have "add_mset a' (mset (map fst ab)) - {# a'' #} =
            add_mset a'' (mset as) - {# a'' #}" by simp
          with True False have "add_mset a (mset (map fst ab) - {# a'' #}) = mset as" by simp
          moreover have "a \<in># add_mset a (mset (map fst ab) - {# a'' #})" by simp
          ultimately show ?thesis by simp
        next
          case False note F' = False
          with Cons show ?thesis
          proof (cases "a' = a''")
            case False
            from Cons have "add_mset a' (mset (map fst ab)) - {# a' #} =
              add_mset a'' (mset as) - {# a' #}" by simp
            with False have "mset (map fst ab) = mset (a'' # (remove1 a' as))" by simp
            with Cons F' have "idx_of (a'' # (remove1 a' as)) a \<noteq> None" by fastforce
            with F'' F' show ?thesis by simp
          qed simp_all
        qed
      qed simp_all
    qed simp_all
  qed
qed simp_all

end


theory
  WhileT_Rules_Examples
imports
  Sepreftime
begin

lemma
  assumes "whileT b c s = r"
  assumes IS: "\<And>s t'. I s = Some t' \<Longrightarrow> b s  \<Longrightarrow> c s \<noteq> FAILi \<and>  lst (c s) I \<ge> Some t'"
    (*  "T (\<lambda>x. T I (c x)) (SPECT (\<lambda>x. if b x then I x else None)) \<ge> Some 0" *)
  assumes "I s = Some t'"
  assumes wf: "wf {(y, x)|x M y. I x \<noteq> None \<and> b x \<and> c x = SPECT M \<and> M y \<noteq> None}"
  shows whileT_rule: "lst r (\<lambda>x. if b x then None else I x) \<ge> Some t'"
  using assms(1,3)
  unfolding whileT_def
proof (induction arbitrary: t' rule: RECT_wf_induct[where R="{(y, x)|x M y. I x \<noteq> None \<and> b x \<and> c x = SPECT M \<and> M y \<noteq> None}"])
  case 1
  show ?case by fact
next
  case 2
  then show ?case by refine_mono
next
  case step: (3 x D r t')

  { assume b:"b x"
    with  IS step(3) have pff: "Some t' \<le> lst (c x) I" and cnofail: "c x \<noteq> FAILi" by auto
    from b step(2) have r: "r = bindT (c x) D" by auto
    from cnofail obtain M where cM: "c x = SPECT M" by force

    from step(3) pff have inf: "I x \<le> lst (c x) I" by auto

    have k: "\<And>y. M y \<noteq> None \<Longrightarrow> I y \<noteq> None"
      using inf[unfolded T_pw cM mii_alt] by (auto simp: mm2_def step(3) split: option.splits)

    { fix y t''
      have " None \<noteq> M y \<Longrightarrow> I y = Some t'' \<Longrightarrow> Some t'' \<le> lst (D y) (\<lambda>x. if b x then None else I x)"
        apply(rule step(1)[where y=y])
        subgoal apply auto subgoal using step(3) by auto subgoal using b by simp apply(rule exI[where x=M]) using cM
          using leI by fastforce
         apply simp   by metis
    } note pf=this

    { fix y

      from step(3) inf have pot_pays: "\<And>y. I x \<le> mm2 (I y) (M y)" unfolding T_pw mii_alt using cM by (auto split: nrest.splits)
      from pot_pays have ineq: "I x \<le> mm2 (I y) (M y)" by auto

      have " Some t' \<le> mii (\<lambda>y. lst (D y) (\<lambda>x. if b x then None else I x)) (c x) y"
        unfolding mii_alt using cM apply(auto split: nrest.splits)
        unfolding mm2_def apply (auto split: option.splits)
        subgoal using pf
          by (metis (no_types, lifting) Inf_option_def RETURNT_alt T_RETURNT lst_def k less_eq_option_Some_None option.distinct(1))
      proof -
        fix th tn  (* time that we have, time that we need *)
        assume  My: "M y = Some tn" and T: "lst (D y) (\<lambda>x. if b x then None else I x) = Some th"

        from ineq obtain tiy where Iy: "I y = Some tiy" using My step(3) by(auto simp: mm2_def split: if_splits option.splits)
        with ineq My step(3) have 2: "tiy \<ge> tn" and a2: "t' \<le> tiy - tn" by (auto simp: mm2_def split: if_splits)
        from cM My pf have "Some tiy \<le> lst (D y) (\<lambda>x. if b x then None else I x)" by (simp add: \<open>I y = Some tiy\<close>)
        with T have 3: "tiy \<le> th" by simp

        { assume less: "th < tn"
          from 3 2 less show False by simp
        }
        {
          assume notless: "~ th < tn"
          from notless have "tn \<le> th" by auto
          from enat_minus_mono[OF this 3]   have "tiy - tn \<le> th - tn" by auto
          with a2 show "t' \<le> th - tn" by auto
        }
      qed
    }
    then have "Some t' \<le> lst (bindT (c x) D) (\<lambda>x. if b x then None else I x)"
      apply(simp add: T_bindT) unfolding T_pw by auto
    then have ?case unfolding r by auto
  }
  moreover
  {
    assume nb: "\<not> b x"
    with  step(2) have "r = RETURNT x" by auto
    then have ?case using nb step(3) by (simp add: T_RETURNT)
  }
  ultimately have i: ?case by auto

  thm step.IH
  note IH = step.IH[OF _ refl]
  note IS' = IS[THEN conjunct2]
  note step.hyps[symmetric, simp]

  from step.prems
  have ?case
    apply clarsimp apply safe
    subgoal
      apply vcg
      apply (rule T_conseq6)
        apply (rule IS')
      apply simp_all
      apply (rule T_conseq6)
        apply (rule IH)
      subgoal for y  by simp
      apply simp
      by (auto split: if_splits)
    subgoal by vcg
    done
  from i show ?case .
qed

lemma
  assumes "whileT b c s = r"
  assumes IS[vcg_rules]: "\<And>s t'. I s = Some t' \<Longrightarrow> b s
           \<Longrightarrow>    lst (c s) (\<lambda>s'. if (s',s)\<in>R then I s' else None) \<ge> Some t'"
    (*  "T (\<lambda>x. T I (c x)) (SPECT (\<lambda>x. if b x then I x else None)) \<ge> Some 0" *)
  assumes "I s = Some t"
  assumes wf: "wf R"
  assumes exit: "\<And>s t'. I s = Some t' \<Longrightarrow> \<not>b s \<Longrightarrow> Q s \<ge> Some t'"
  shows whileT_rule''a_: "lst r Q \<ge> Some t"
  using assms(1,3)
  unfolding whileT_def
proof (induction arbitrary: t rule: RECT_wf_induct[where R="R"])
  case 1
  show ?case by fact
next
  case 2
  then show ?case by refine_mono
next
  case step: (3 x D r t')
  note IH[vcg_rules] = step.IH[OF _ refl]
  note step.hyps[symmetric, simp]

  from step.prems
  show ?case
    apply clarsimp
    apply safe
    apply vcg'   using exit by simp
qed

lemma waux1: "(\<forall>s t'. I s = Some t' \<longrightarrow> b s  \<longrightarrow> c s \<noteq> FAILi \<and>  lst (c s) (Q s) \<ge> Some t')
    = (lst (SPECT (\<lambda>x. if b x then I x else None)) (\<lambda>s. lst (c s) (Q s)) \<ge> Some 0)"
  apply(subst (2)T_pw) unfolding mii_alt apply simp
  by (force simp: mm2_def split: option.splits)

lemma waux2: "(\<forall>s t'. I s = Some t' \<longrightarrow> lst (whileT b c s) (\<lambda>x. if b x then None else I x) \<ge> Some t')
      = (lst (SPECT I) (\<lambda>s. lst (whileT b c s) (\<lambda>x. if b x then None else I x)) \<ge> Some 0)"
  apply(subst (2) T_pw) unfolding mii_alt apply simp
  by (force simp: mm2_def split: option.splits)

lemma
  assumes IS: "lst (SPECT (\<lambda>x. if b x then I x else None)) (\<lambda>s. lst (c s) (\<lambda>s'. if (s',s)\<in>R then I s' else None)) \<ge> Some 0"
  assumes wf: "wf R"
  shows whileT_rule''_: "lst (SPECT I) (\<lambda>s. lst (whileT b c s) (\<lambda>x. if b x then None else I x)) \<ge> Some 0"
  using IS   unfolding  waux1[symmetric] unfolding  waux2[symmetric]  using whileT_rule''[OF _ _ _ wf]
  by blast

lemma
  assumes "whileT b c s = r"
  assumes IS[vcg_rules]: "\<And>s t'. I s = Some t' \<Longrightarrow> b s  \<Longrightarrow> lst (c s) I \<ge> Some t'"
    (*  "T (\<lambda>x. T I (c x)) (SPECT (\<lambda>x. if b x then I x else None)) \<ge> Some 0" *)
  assumes "I s = Some t'"
  assumes wf: "wf {(y, x)|x M y. I x \<noteq> None \<and> b x \<and> c x = SPECT M \<and> M y \<noteq> None}"
  shows whileT_rule': "lst r (\<lambda>x. if b x then None else I x) \<ge> Some t'"
  using assms(1,3)
  unfolding whileT_def
proof (induction arbitrary: t' rule: RECT_wf_induct[where R="{(y, x)|x M y. I x \<noteq> None \<and> b x \<and> c x = SPECT M \<and> M y \<noteq> None}"])
  case 1
  show ?case by fact
next
  case 2
  then show ?case by refine_mono
next
  case step: (3 x D r t')

  note IH[vcg_rules] = step.IH[OF _ refl]
  note step.hyps[symmetric, simp]

  from step.prems
  show ?case
    apply clarsimp
    apply safe
     apply vcg'
    done
qed

subsection "Examples"

experiment
begin

lemma
  assumes c: "c = (\<lambda>s. SPECT [s-1\<mapsto>1])"
      and n: "S\<le>n"
  shows ex4: "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s = 0 then Some (enat n) else None) \<ge> Some 0"
  apply(rule T_conseq4)
   apply(rule whileT_rule'''[where I="\<lambda>s. if s\<le>n then Some (s) else None" ])
      apply simp
  subgoal unfolding c unfolding progress_def by (auto split: if_splits simp add:  )
  subgoal unfolding c apply(auto simp: T_REST split: if_splits)
    by(auto simp: mm2_def mm3_def one_enat_def)
  using n by (auto simp: mm3_Some_conv split: if_splits)

lemma assumes "c = (\<lambda>s. SPECT [s-1\<mapsto>1])"
      and n: "S\<le>n"
      shows ex4': "(whileT (\<lambda>s. s>0) c (S::nat)) \<le> SPECT (\<lambda>s. if s = 0 then Some (enat n) else None)"
  apply(rule T_specifies_I)
  apply(rule ex4) using assms by auto

lemma
  assumes c: "c = (\<lambda>s. SPECT [s-1\<mapsto>1])"
      and n: "S\<le>n"
  shows "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s = 0 then Some (enat n) else None) \<ge> Some 0"
  apply(rule T_conseq4)
   apply(rule whileT_rule''[where I="\<lambda>s. if s\<le>n then Some (enat (n - s)) else None"
            and R="measure nat"])
      apply simp
  subgoal unfolding c apply (simp add: T_REST mm2_def) apply (auto split: if_splits)
     apply (simp add: one_eSuc zero_enat_def)
    by (simp add: one_enat_def)
    using n apply simp
  subgoal  by blast
  by (auto split: if_splits)

term emb'
lemma
  assumes c: "c = (\<lambda>s. SPECT [s-1\<mapsto>1])"
      and n: "S\<le>n"
  shows "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s = 0 then Some (enat n) else None) \<ge> Some 0"
  apply(rule T_conseq4)
   apply(rule whileT_rule[where I="\<lambda>s. if s\<le>n then Some (enat (n - s)) else None"])
      apply simp
  subgoal unfolding c apply (simp add: T_REST mm2_def) apply (auto split: if_splits)
     apply (simp add: one_eSuc zero_enat_def)
    by (simp add: one_enat_def)
    using n apply simp
  subgoal using c apply auto
    apply(rule wf_bounded_measure[where ub="\<lambda>_. n" and f="\<lambda>s. n - s"])
    by auto
  by (auto split: if_splits)

lemma                                       (* hmmm *)
  assumes c: "c = (\<lambda>s. SPECT (\<lambda>s'. if s'<s \<and> even s then Some C else None))"
  shows "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s = 0 then Some \<infinity> else None) \<ge> Some 0"
  apply(rule T_conseq4)
   apply(rule whileT_rule[where I="\<lambda>s. Some \<infinity>"])
      apply simp
  subgoal for s unfolding c by (simp add: T_pw mii_alt mm2_def)
    apply simp
  subgoal using c apply auto
    by (smt case_prodI le_less_linear mem_Collect_eq nz_le_conv_less prod.sel(2) wf wf_def)
  by (auto split: if_splits)

lemma
  assumes c[vcg_rules]: "\<And>s. c s \<le> SPECT (\<lambda>s'. if s'<s \<and> even s then Some C else None)"
  shows "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s \<le> 0 then Some \<infinity> else None) \<ge> Some 0"
  apply(rule  whileT_rule''[where I="\<lambda>s. Some \<infinity>" and R="{(x, y). x < y}", THEN T_conseq4])
      apply simp
     apply(rule T_conseq4)
      apply(rule T_specifies_rev[OF c])
     apply (auto split: if_splits)[1]
  apply simp apply(fact wf) by (auto split: if_splits)

print_statement whileT_rule''

lemma  whileTI_rule[vcg_rules]:
  assumes
      "\<And>s t'. I s = Some t' \<Longrightarrow> b s \<Longrightarrow> Some t' \<le> lst (c s) (\<lambda>s'. if (s', s) \<in> R then I s' else None)"
    and "I s = Some t'"
    and "wf R"
  shows "Some t' \<le> lst (whileTI I R b c s) (\<lambda>x. if b x then None else I x)"
  unfolding   whileTI_def
  apply(rule whileT_rule''[where I=I and R=R])
  apply simp apply fact+ done

lemma                                       (* hmmm *)
  assumes c[vcg_rules]: "\<And>s. Some 0 \<le> lst (c s) (\<lambda>s'. if s' < s \<and> even s then Some C else None)"
  shows "lst (whileTI (\<lambda>s. Some \<infinity>) {(x, y). x < y} (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s \<le> 0 then Some \<infinity> else None) \<ge> Some 0"
  apply vcg
     apply (auto split: if_splits)   by(fact wf)

lemma   fixes n :: nat
  assumes [vcg_rules]: "lst f (\<lambda>s. if s \<le> n then Some 1 else None) \<ge> Some 0"
   and  c[vcg_rules]: "\<And>s. Some 0 \<le> lst (c s) (\<lambda>s'. if s' < s then Some (enat C) else None)"
   and C: "C>0"
  shows "lst (
        do { n \<leftarrow> f;
             whileT (\<lambda>s. s>0) c n })  (\<lambda>s. if s \<le> 0 then Some (1+C*n) else None) \<ge> Some 0"
    (* note that n is bound from the outside ! *)
  apply(subst whileTI_def[symmetric, where I="(\<lambda>s. if s\<le>n then Some (1+C*(enat (n-s))) else None)"
                                    and R="  {(x, y). x < y}"])
  apply vcg
  apply(auto simp: wf one_enat_def split: if_splits)
  proof -
    fix x s xa
    assume "x \<le> n " " s \<le> n " " xa < s"
    then have i: "((n - s) + 1) \<le> (n - xa)" by linarith
    have "C * (n - s) + C = C * ((n - s) + 1)" by simp
    also have "\<dots> \<le> C * (n - xa)"  apply(rule mult_left_mono) apply fact by simp
    finally
    show "C * (n - s) + C \<le> C * (n - xa)" .
  qed

lemma   fixes n :: nat
  assumes [vcg_rules]: "lst f (\<lambda>s. if s \<le> n then Some 1 else None) \<ge> Some 0"
   and  c[vcg_rules]: "\<And>s. Some 0 \<le> lst (c s) (\<lambda>s'. if s' < s then Some (enat C) else None)"
   and C: "C>0"
  shows "lst (
        do { n \<leftarrow> f;
             whileTI (\<lambda>s. if s\<le>n then Some (1+C*(enat (n-s))) else None)  {(x, y). x < y}  (\<lambda>s. s>0) c n })
         (\<lambda>s. if s \<le> 0 then Some (1+C*n) else None)  \<ge> Some 0"
    (* note that n in the Invariant is bound from the inside, very much in contrast to the example above! ! *)
  apply vcg
  apply(auto simp: wf one_enat_def split: if_splits)
  proof -
    fix x s xa
    assume "x \<le> n " " s \<le> x " " xa < s"
    then have i: "((x - s) + 1) \<le> (x - xa)" by linarith
    have "C * (x - s) + C = C * ((x - s) + 1)" by simp
    also have "\<dots> \<le> C * (x - xa)"  apply(rule mult_left_mono) apply fact by simp
    finally
    show "C * (x - s) + C \<le> C * (x - xa)" .
  qed

lemma dont_care_about_runtime_as_long_as_it_terminates:
    (* here:
        * the cost C of of the loop body (decrementing s) may even be \<infinity>
        * the starting state S is also arbitrary *)
  assumes c: "c = (\<lambda>s. SPECT [s-1\<mapsto>C])"
  shows "lst (whileT (\<lambda>s. s>0) c (S::nat)) (\<lambda>s. if s = 0 then Some \<infinity> else None) \<ge> Some 0"
  apply(rule T_conseq4)
   apply(rule whileT_rule[where I="\<lambda>s. Some \<infinity>"])
      apply simp
  subgoal for s unfolding c by (simp add: T_REST mm2_def)
    apply simp
  subgoal using c apply auto
    by (smt case_prodI le_less_linear mem_Collect_eq nz_le_conv_less prod.sel(2) wf wf_def)
  by (auto split: if_splits)

end

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Chain
  imports Agent
begin

definition tauChain :: "ccs \<Rightarrow> ccs \<Rightarrow> bool" ("_ \<Longrightarrow>\<^sub>\<tau> _" [80, 80] 80)
  where "P \<Longrightarrow>\<^sub>\<tau> P' \<equiv> (P, P') \<in> {(P, P') | P P'. P \<longmapsto>\<tau> \<prec> P'}^*"

lemma tauChainInduct[consumes 1, case_names Base Step]:
  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "Prop P"
  and     "\<And>P' P''. \<lbrakk>P \<Longrightarrow>\<^sub>\<tau> P'; P' \<longmapsto>\<tau> \<prec> P''; Prop P'\<rbrakk> \<Longrightarrow> Prop P''"

  shows "Prop P'"
using assms
by(auto simp add: tauChain_def elim: rtrancl_induct)

lemma tauChainRefl[simp]:
  fixes P :: ccs

  shows "P \<Longrightarrow>\<^sub>\<tau> P"
by(auto simp add: tauChain_def)

lemma tauChainCons[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<longmapsto>\<tau> \<prec> P''"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using assms
by(auto simp add: tauChain_def) (blast dest: rtrancl_trans)

lemma tauChainCons2[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P' \<longmapsto>\<tau> \<prec> P''"
  and     "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using assms
by(auto simp add: tauChain_def) (blast dest: rtrancl_trans)

lemma tauChainAppend[dest]:
  fixes P   :: ccs
  and   P'  :: ccs
  and   P'' :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<Longrightarrow>\<^sub>\<tau> P''"

  shows "P \<Longrightarrow>\<^sub>\<tau> P''"
using `P' \<Longrightarrow>\<^sub>\<tau> P''` `P \<Longrightarrow>\<^sub>\<tau> P'`
by(induct rule: tauChainInduct) auto

lemma tauChainSum1:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P \<noteq> P'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> P'"
using assms
proof(induct rule: tauChainInduct)
  case Base
  thus ?case by simp
next
  case(Step P' P'')
  thus ?case
    by(case_tac "P=P'") (auto intro: Sum1 simp add: tauChain_def)
qed

lemma tauChainSum2:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     "Q \<noteq> Q'"

  shows "P \<oplus> Q \<Longrightarrow>\<^sub>\<tau> Q'"
using assms
proof(induct rule: tauChainInduct)
  case Base
  thus ?case by simp
next
  case(Step Q' Q'')
  thus ?case
    by(case_tac "Q=Q'") (auto intro: Sum2 simp add: tauChain_def)
qed

lemma tauChainPar1:
  fixes P  :: ccs
  and   P' :: ccs
  and   Q  :: ccs

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P' \<parallel> Q"
using assms
by(induct rule: tauChainInduct) (auto intro: Par1)

lemma tauChainPar2:
  fixes Q  :: ccs
  and   Q' :: ccs
  and   P  :: ccs

  assumes "Q \<Longrightarrow>\<^sub>\<tau> Q'"

  shows "P \<parallel> Q \<Longrightarrow>\<^sub>\<tau> P \<parallel> Q'"
using assms
by(induct rule: tauChainInduct) (auto intro: Par2)

lemma tauChainRes:
  fixes P  :: ccs
  and   P' :: ccs
  and   x  :: name

  assumes "P \<Longrightarrow>\<^sub>\<tau> P'"

  shows "\<lparr>\<nu>x\<rparr>P \<Longrightarrow>\<^sub>\<tau> \<lparr>\<nu>x\<rparr>P'"
using assms
by(induct rule: tauChainInduct) (auto dest: Res)

lemma tauChainRepl:
  fixes P :: ccs

  assumes "P \<parallel> !P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "P' \<noteq> P \<parallel> !P"

  shows "!P \<Longrightarrow>\<^sub>\<tau> P'"
using assms
apply(induct rule: tauChainInduct)
apply auto
apply(case_tac "P' \<noteq> P \<parallel> !P")
apply auto
apply(drule Bang)
apply(simp add: tauChain_def)
by auto

end


theory week03B_demo_HOL imports Pure begin

text {* Defining HOL *}

text {* Technical Setup, introducing a new logic *}

class type
default_sort type

typedecl bool
typedecl ind

axiomatization where bool_arity: "OFCLASS(bool, type_class)"
instance "bool" :: type by (rule bool_arity)

axiomatization where ind_arity: "OFCLASS(ind, type_class)"
instance "ind" :: type by (rule ind_arity)

axiomatization where fun_arity: "OFCLASS('a \<Rightarrow> 'b, type_class)"
instance "fun" :: (type, type) type by (rule fun_arity)

judgment
  Trueprop      :: "bool \<Rightarrow> prop"  ("(_)" 5)

-- ---------------------------------

axiomatization
  Eq            :: "'a \<Rightarrow> 'a \<Rightarrow> bool"      (infixl "=" 50) and
  Imp           :: "bool \<Rightarrow> bool \<Rightarrow> bool"  (infixr "\<longrightarrow>" 25) and
  Eps           :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"    (binder "SOME" 10)

definition True :: bool
  where "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"

definition All :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<forall>" 10)
  where "All P \<equiv> (P = (\<lambda>x. True))"

definition Ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<exists>" 10)
  where "Ex P \<equiv> \<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q"

definition False :: bool
  where "False \<equiv> (\<forall>P. P)"

definition Not :: "bool \<Rightarrow> bool"  ("\<not> _" [40] 40)
  where "\<not> P \<equiv> P \<longrightarrow> False"

definition And :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<and>" 35)
  where "P \<and> Q \<equiv> \<forall>R. (P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> R"

definition Or :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<or>" 30)
  where "P \<or> Q \<equiv> \<forall>R. (P \<longrightarrow> R) \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> R"

definition If:: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" 10)
  where "If P x y \<equiv> SOME z. (P=True \<longrightarrow> z=x) \<and> (P=False \<longrightarrow> z=y)"

definition inj:: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "inj f  \<equiv> \<forall>x y. f x = f y \<longrightarrow> x = y"

definition  surj:: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "surj f \<equiv> \<forall>y. \<exists>x. y = f x"

text {* Additional concrete syntax *}

syntax
  "_not_equal"  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<noteq>" 50)
translations
  "x \<noteq> y"  == "\<not>(x = y)"

text {* Axioms and basic definitions *}

axiomatization where
  refl:  "t = t"  and
  subst: "\<lbrakk> s = t; P s \<rbrakk> \<Longrightarrow> P t" and
  ext:   "(\<And>x. f x = g x) \<Longrightarrow> (\<lambda>x. f x) = (\<lambda>x. g x)"

axiomatization where
  impI:  "(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q" and
  mp:    "\<lbrakk> P\<longrightarrow>Q;  (P::bool) \<rbrakk> \<Longrightarrow> Q" and
  iff:   "(P\<longrightarrow>Q) \<longrightarrow> (Q\<longrightarrow>P) \<longrightarrow> (P=Q)" and
  True_or_False: "(P=True) \<or> (P=False)" and
  infinity: "\<exists>f :: ind \<Rightarrow> ind. inj f \<and> \<not>surj f"

axiomatization where
  someI: "P x \<Longrightarrow> P (SOME x. P x)"

text {* Deriving the standard proof rules in HOL *}

text {* Implication *}

thm mp

-- {* we want to show @{text "\<lbrakk> P \<longrightarrow> Q; P; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"} *}
lemma impE:
  assumes PQ: "P \<longrightarrow> Q"
  assumes P: "P"
  assumes QR: "Q \<Longrightarrow> R"
  shows "R"
  apply (rule QR)
  apply (insert PQ) thm mp
  apply (drule mp)
   apply (rule P)
  apply assumption
  done

-- -------------------------------

text {* True *}

lemma TrueI: "True"
  apply (unfold True_def)
  apply (rule refl)
  done

text {* side track: Equality *}

lemma sym: "s = t \<Longrightarrow> t = s" thm subst
  apply (erule subst)
  apply (rule refl)
  done

lemma fun_cong: "f = g \<Longrightarrow> f x = g x" thm subst
  apply (erule subst)
  apply (rule refl)
  done

thm mp
thm iff
lemma iffI:
  assumes PQ: "P \<Longrightarrow> Q"
  assumes QP: "Q \<Longrightarrow> P"
  shows "P = Q"
  apply (rule mp)
   apply (rule mp)
    apply (insert iff [where P=P and Q=Q])
    apply assumption
   apply (rule impI)
   apply (rule PQ)
   apply assumption
  apply (rule impI)
  apply (rule QP)
  apply assumption
  done

lemma iffD1: "Q = P \<Longrightarrow> Q \<Longrightarrow> P"
  apply (rule subst)
   apply assumption
  apply assumption
  done

lemma iffD2: "P = Q \<Longrightarrow> Q \<Longrightarrow> P" thm sym
  apply (drule sym)
  apply (erule iffD1)
   apply assumption
  done

text {* back to True *}

lemma eqTrueI: "P \<Longrightarrow> P = True"
  apply (rule iffI)
   apply (rule TrueI)
  apply assumption
  done

lemma eqTrueE: "P = True \<Longrightarrow> P" thm iffD2
  apply (drule iffD2)
   apply (rule TrueI)
  apply assumption
  done

-- -------------------------------

text {* Universal Quantifier *}

lemma allI:
  assumes P: "\<And>x. P x"
  shows "\<forall>x. P x"
  apply (unfold All_def)
  apply (rule ext) thm eqTrueI
  apply (rule eqTrueI)
  apply (rule P)
  done

lemma spec: "\<forall>x. P x \<Longrightarrow> P x"
  apply (unfold All_def) thm eqTrueE
  apply (rule eqTrueE) thm fun_cong
  apply (drule fun_cong)
  apply assumption
  done

lemma allE:
  assumes all: "\<forall>x. P x"
  assumes R: "P x \<Longrightarrow> R"
  shows "R"
  apply (rule R)
  apply (insert all)
  apply (erule spec)
  done

-- -------------------------------

text {* False *}

lemma FalseE:
  "False \<Longrightarrow> P"
  apply (unfold False_def)
  apply (erule_tac x=P in allE)
  apply assumption
  done

lemma False_neq_True:
  "False = True \<Longrightarrow> P"  thm eqTrueE
  apply (drule eqTrueE)
  apply (erule FalseE)
  done

-- -------------------------------

text {* Negation *}

lemma notI:
  assumes P: "P \<Longrightarrow> False"
  shows "\<not>P"
  apply (unfold Not_def)
  apply (rule impI)
  apply (rule P)
  apply assumption
  done

lemma notE: "\<lbrakk> \<not>P; P \<rbrakk> \<Longrightarrow> R"
  apply (unfold Not_def)
  apply (erule impE)
   apply assumption
  apply (erule FalseE)
  done

lemma False_not_True: "False \<noteq> True"
  apply (rule notI) thm False_neq_True
  apply (erule False_neq_True)
  done

-- -------------------------------

text {* Existential Quantifier *}

lemma exI:
  "P x \<Longrightarrow> \<exists>x. P x"
  apply (unfold Ex_def)
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x=x in allE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma exE:
  assumes ex: "\<exists>x. P x"
  assumes R: "\<And>x. P x \<Longrightarrow> R"
  shows "R"
  apply (insert ex)
  apply (unfold Ex_def) thm spec
  apply (drule spec) thm mp
  apply (drule mp)
   apply (rule allI)
   apply (rule impI)
   apply (rule R)
   apply assumption
  apply assumption
  done

-- -------------------------------

text {* Conjunction *}

lemma conjI: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> Q"
  apply (unfold And_def)
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma conjE:
  assumes PQ: "P \<and> Q"
  assumes R: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> R"
  shows R
  apply (insert PQ)
  apply (unfold And_def)
  apply (erule allE)
  apply (erule impE)
   apply (rule impI)
   apply (rule impI)
   apply (rule R)
    apply assumption
   apply assumption
  apply assumption
  done

-- -------------------------------

text {* Disjunction *}

lemma disjI1:
  "P \<Longrightarrow> P \<or> Q"
  apply (unfold Or_def)
  apply (rule allI)
  apply (rule impI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma disjI2:
  "Q \<Longrightarrow> P \<or> Q"
  apply (unfold Or_def)
  apply (rule allI)
  apply (rule impI)
  apply (rule impI)
  apply (erule impE, assumption, assumption)
  done

lemma disjE:
  assumes PQ: "P \<or> Q"
  assumes P: "P \<Longrightarrow> R"
  assumes Q: "Q \<Longrightarrow> R"
  shows "R"
  apply (insert PQ)
  apply (unfold Or_def)
  apply (erule allE)
  apply (erule impE)
   apply (rule impI)
   apply (rule P)
   apply assumption
  apply (erule impE)
   apply (rule impI)
   apply (rule Q)
   apply assumption
  apply assumption
  done

-- -------------------------------

text {* Classical Logic *}

lemma classical:
  assumes P: "\<not>P \<Longrightarrow> P"
  shows P
  apply (insert True_or_False [where P=P])
  apply (erule disjE)
   apply (erule eqTrueE)
  apply (rule P)
  apply (rule notI)
  apply (rule subst)
   apply assumption
  apply assumption
  done

lemma notnotD:
  "\<not>\<not>P \<Longrightarrow> P"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma disjCI:
  assumes P: "\<not>Q \<Longrightarrow> P"
  shows "P \<or> Q"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule P)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma tertium_non_datur:
  "P \<or> \<not>P"
  apply (rule disjCI)
  apply (drule notnotD)
  apply assumption
  done

-- -------------------------------

text {* Choice *}

lemma someI_ex: "\<exists>x. P x \<Longrightarrow> P (SOME x. P x)"
  apply (erule exE)
  apply (erule someI)
  done

lemma someI2:
  assumes a: "P a"
  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
  shows "Q (SOME x. P x)"
  apply (insert a)
  apply (drule someI, drule PQ)
  apply assumption
  done

lemma some_equality:
  assumes a: "P a"
  assumes P: "\<And>x. P x \<Longrightarrow> x=a"
  shows "(SOME x. P x) = a"
  apply (rule someI2)
   apply (rule a)
  apply (rule P)
  apply assumption
  done

lemma some_eq_ex:
  "P (SOME x. P x) = (\<exists>x. P x)"
  apply (rule iffI)
   apply (rule exI)
   apply assumption
  apply (erule someI_ex)
  done

-- -------------------------------

text {* if-then-else *}

lemma if_True:
  "(if True then s else t) = s"
  apply (unfold If_def)
  apply (rule some_equality)
   apply (rule conjI)
    apply (rule impI)
    apply (rule refl)
   apply (rule impI)
   apply (drule sym)
   apply (erule False_neq_True)
  apply (erule conjE)
  apply (erule impE)
   apply (rule refl)
  apply assumption
  done

lemma if_False:
  "(if False then s else t) = t"
  apply (unfold If_def) thm some_equality
  apply (rule some_equality)
   apply (rule conjI)
    apply (rule impI)
    apply (erule False_neq_True)
   apply (rule impI)
   apply (rule refl)
  apply (erule conjE)
  apply (erule impE, rule refl)
  apply assumption
  done

end


section "Beta Normalization"

(*
  Much of this material is directly copied and adapted from @{dir "~~/src/HOL/Proofs/Lambda"}

  Proofs are in a lot of cases very ugly as they were copied+fixed
*)

theory BetaNorm
  imports Term
begin

inductive beta :: "term \<Rightarrow> term \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs T s $ t \<rightarrow>\<^sub>\<beta> subst_bv2 s 0 t"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s $ u \<rightarrow>\<^sub>\<beta> t $ u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> u $ s \<rightarrow>\<^sub>\<beta> u $ t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"

abbreviation
  beta_reds :: "term \<Rightarrow> term \<Rightarrow> bool" (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t == beta\<^sup>*\<^sup>* s t"

inductive_cases beta_cases [elim!]:
  "Bv i \<rightarrow>\<^sub>\<beta> t"
  "Fv idn S \<rightarrow>\<^sub>\<beta> t"
  "Abs T r \<rightarrow>\<^sub>\<beta> s"
  "s $ t \<rightarrow>\<^sub>\<beta> u"

declare if_not_P [simp] not_less_eq [simp]

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> Abs T s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs T s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> s $ t \<rightarrow>\<^sub>\<beta>\<^sup>* s' $ t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s $ t \<rightarrow>\<^sub>\<beta>\<^sup>* s $ t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s $ t \<rightarrow>\<^sub>\<beta>\<^sup>* s' $ t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

theorem subst_bv2_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> subst_bv2 r k u \<rightarrow>\<^sub>\<beta> subst_bv2 s k u"
  by (induct arbitrary: k u set: beta) (simp_all add: subst_bv2_subst_bv2[symmetric])

theorem subst_bv2_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> subst_bv2 r i t  \<rightarrow>\<^sub>\<beta>\<^sup>* subst_bv2 s i t"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule subst_bv2_preserves_beta)
  done

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
proof (induction arbitrary: i set: beta)
  case (beta T s t)
  then show ?case
    using lift_subst by force
qed auto
theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule lift_preserves_beta)
  done

theorem subst_bv2_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> subst_bv2 t i r \<rightarrow>\<^sub>\<beta>\<^sup>* subst_bv2 t i s"
  apply (induct t arbitrary: r s i)
    apply (solves \<open>simp add: r_into_rtranclp\<close>)+
  using lift_preserves_beta by (auto simp add: rtrancl_beta_App)

theorem subst_bv2_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> subst_bv2 t i r \<rightarrow>\<^sub>\<beta>\<^sup>* subst_bv2 t i s"
  apply (induct set: rtranclp)
    apply (auto elim: rtranclp_trans subst_bv2_preserves_beta2)
  done

lemma beta_preserves_typ_of1: "typ_of1 Ts r = Some T \<Longrightarrow> r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> typ_of1 Ts s = Some T"
proof (induction Ts r arbitrary: s T rule: typ_of1.induct)
  case (4 Ts T body)
  then show ?case
    by (smt beta_cases(3) typ_of1.simps(4) typ_of_Abs_body_typ')
next
  case (5 Ts f u)
  from this obtain argT where argT: "typ_of1 Ts u = Some argT" and "typ_of1 Ts f = Some (argT \<rightarrow> T)"
    by (meson typ_of1_split_App_obtains)

  from 5 show ?case  apply -
    apply (ind_cases "f $ u \<rightarrow>\<^sub>\<beta> s" for f u s)
    using \<open>typ_of1 Ts f = Some (argT \<rightarrow> T)\<close> argT typ_of1_subst_bv_gen'
      typ_of_Abs_body_typ' by (fastforce simp add: substn_subst_n)+
qed (use beta.cases in \<open>blast+\<close>)

lemma beta_preserves_typ_of: "typ_of r = Some T \<Longrightarrow> r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> typ_of s = Some T"
  by (metis beta_preserves_typ_of1 typ_of_def)

lemma beta_star_preserves_typ_of1: "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> typ_of1 Ts r = Some T  \<Longrightarrow> typ_of1 Ts s = Some T"
proof (induction rule: rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case
    by simp
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    using beta_preserves_typ_of1 by blast
qed
(*
  Convert beta_norm to the inductive predicates. Then later show that one beta step can be justified
  using proves
*)

lemma beta_reducible_imp_beta_step: "beta_reducible t \<Longrightarrow> \<exists>t'. t \<rightarrow>\<^sub>\<beta> t'"
proof (induction t)
  case (App t1 t2)
  then show ?case using App by (cases t1) auto
qed auto

lemma beta_step_imp_beta_reducible: "t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> beta_reducible t"
proof (induction t t' rule: beta.induct)
  case (beta T s t)
  then show ?case by simp
next
case (appL s t u)
  then show ?case by (cases s) auto
next
  case (appR s t u)
  then show ?case using beta_reducible.elims by blast
next
  case (abs s t T)
  then show ?case by simp
qed

lemma beta_norm_imp_beta_reds: assumes "beta_norm t = Some t'" shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'"
  using assms proof (induction arbitrary: t t' rule: beta_norm.fixp_induct)
  case 1
  then show ?case
    by (smt Option.is_none_def ccpo.admissibleI chain_fun flat_lub_def flat_ord_def fun_lub_def
        insertCI is_none_code(2) mem_Collect_eq option.lub_upper subsetI)
next
  case 2
  then show ?case
    by simp
next
  case (3 comp)
  then show ?case
  proof(cases t)
  next
    case (App f u)
    note fu = App
    then show ?thesis
    proof (cases "comp f")
      case None
      show ?thesis
      proof(cases f)
        case (Abs B b)
        then show ?thesis
          by (metis (mono_tags, lifting) "3.IH" "3.prems" Core.subst_bv_def Core.term.simps(29)
              Core.term.simps(30) beta fu rtranclp.rtrancl_into_rtrancl rtranclp.rtrancl_refl rtranclp_trans)
      qed (use 3 None in \<open>simp_all add: fu split: term.splits option.splits if_splits\<close>)
    next
      case (Some fo)
      then show ?thesis
      proof(cases fo)
        case (Ct n T)
        then show ?thesis
        proof(cases f)
          case (Abs B b)
          then show ?thesis
            by (metis (no_types, lifting) "3.IH" "3.prems" Core.subst_bv_def Core.term.simps(29)
                Core.term.simps(30) beta converse_rtranclp_into_rtranclp fu)
        qed (use 3 Some in \<open>auto simp add: fu split: term.splits option.splits if_split\<close>)
      next
        case (Fv n T)
        then show ?thesis
        proof(cases f)
          case (Abs B b)
          then show ?thesis
            by (metis (no_types, lifting) "3.IH" "3.prems" Core.subst_bv_def Core.term.simps(29)
                Core.term.simps(30) beta converse_rtranclp_into_rtranclp fu)
        qed (use 3 Some in \<open>auto simp add: fu split: term.splits option.splits if_split\<close>)
      next
      case (Bv n)
        then show ?thesis
        proof(cases f)
          case (Abs B b)
          then show ?thesis
            by (metis (no_types, lifting) "3.IH" "3.prems" Core.subst_bv_def Core.term.simps(29)
                Core.term.simps(30) beta converse_rtranclp_into_rtranclp fu)
        qed (use 3 Some in \<open>auto simp add: fu split: term.splits option.splits if_split\<close>)
      next
        case (Abs T t)
        then show ?thesis
        proof(cases f)
          case (Ct n C)
          show ?thesis
            by (metis "3.IH" Abs Core.term.simps(11) Ct Some beta_reducible.simps(7)
                beta_step_imp_beta_reducible converse_rtranclpE)
        next
          case (Fv n C)
          then show ?thesis
            by (metis "3.IH" Abs Fv Some beta_reducible.simps(1,4,8) beta_step_imp_beta_reducible
                converse_rtranclpE)
        next
          case (Bv n)
          then show ?thesis
            by (metis "3.IH" Abs Some beta_cases(1) converse_rtranclpE term.distinct(15))
        next
          case (Abs B b)
          then show ?thesis
            by (metis (no_types, lifting) "3.IH" "3.prems" Core.subst_bv_def Core.term.simps(29)
                Core.term.simps(30) beta converse_rtranclp_into_rtranclp fu)
        next
          case (App a b)
          then show ?thesis
            using 3 apply (simp add: fu Some split: term.splits option.splits if_splits; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp rtrancl_beta_AppL rtranclp_trans)
        qed
      next
        case AppO: (App f u)
        then show ?thesis
        proof(cases f)
          case (Ct n C)
          show ?thesis
            using 3 Some apply (simp add: Ct AppO fu split: term.splits option.splits if_split; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp)
        next
          case (Fv n C)
          then show ?thesis
            using 3 Some apply (simp add: Fv AppO fu split: term.splits option.splits if_split; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp)
        next
          case (Bv n)
          then show ?thesis
            using 3 Some apply (simp add: Bv AppO fu split: term.splits option.splits if_split; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp)
        next
          case (Abs B b)
          then show ?thesis
            using 3 Some apply (simp add: Abs AppO fu split: term.splits option.splits if_split; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp)
        next
          case (App a b)
          then show ?thesis
            using 3 Some apply (simp add: App AppO fu split: term.splits option.splits if_split; fast?)
            by (metis Core.subst_bv_def beta converse_rtranclp_into_rtranclp)
        qed
      qed
    qed
  qed auto
qed

corollary "beta_norm t = Some t' \<Longrightarrow> typ_of1 Ts t = Some T \<Longrightarrow> typ_of1 Ts t' = Some T"
  using beta_norm_imp_beta_reds beta_star_preserves_typ_of1 by blast

lemma beta_imp_beta_norm: assumes "t \<rightarrow>\<^sub>\<beta> t'" "\<not> beta_reducible t'" shows "beta_norm t = Some t'"
  using assms proof (induction rule: beta.induct)
  case (beta T s t)
  then show ?case using not_beta_reducible_imp_beta_norm_unchanged by (auto simp add: subst_bv_def substn_subst_n)
next
  case (appL s t u)
  hence t: "\<not> beta_reducible t" by (fastforce elim: beta_reducible.elims)
  hence IH: "beta_norm s = Some t" using appL.IH by simp
  from appL have u: "\<not> beta_reducible u"
    using beta_reducible.elims by blast
  show ?case
    apply (cases s; cases t)
    using not_beta_reducible_imp_beta_norm_unchanged IH t u appL.prems by auto
next
  case (appR s t u)
  hence t: "\<not> beta_reducible t"
    using beta_reducible.elims by blast
  hence IH: "beta_norm s = Some t" using appR.IH by simp
  from appR have u: "\<not> beta_reducible u"
    using beta_reducible.elims by blast
  show ?case
    apply (cases s; cases u)
    using not_beta_reducible_imp_beta_norm_unchanged IH t u appR.prems by auto
next
  case (abs s t T)
  then show ?case by auto
qed

lemma beta_subst_bv1: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> subst_bv1 s lev x \<rightarrow>\<^sub>\<beta> subst_bv1 t lev x"
proof (induction s t arbitrary: lev rule: beta.induct)
  case (beta T s t)
  then show ?case
    using beta.beta subst_bv2_preserves_beta substn_subst_n by presburger
qed (auto simp add: subst_bv_def)

lemma beta_subst_bv: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> subst_bv x s \<rightarrow>\<^sub>\<beta> subst_bv x t"
  by (simp add: substn_subst_0')

(* typ_of to exclude terms like Bv 0 $ Bv 0
  Probably can get rid of one typ_of somehow

  Problem: Not useable for subst_bv (at lev 0)
*)
lemma subst_bv1_beta:
  "subst_bv1 s (length (T#Ts)) x \<rightarrow>\<^sub>\<beta> subst_bv1 t (length (T#Ts)) x
  \<Longrightarrow> typ_of1 Ts s = Some ty
  \<Longrightarrow> typ_of1 Ts t = Some ty
  \<Longrightarrow> s \<rightarrow>\<^sub>\<beta> t"
proof (induction "subst_bv1 s (length (T#Ts)) x" "subst_bv1 t (length (T#Ts)) x"
    arbitrary: s t T T Ts ty rule: beta.induct)
  case (beta T s t)
  then show ?case
    by (metis beta.simps length_Cons loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 typ_of1_imp_no_loose_bvar)
next
  case (appL s t u)
  then show ?case
    by (metis beta.appL length_Cons loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 typ_of1_imp_no_loose_bvar)
next
  case (appR s t u)
  then show ?case
    by (metis beta.simps length_Cons loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 typ_of1_imp_no_loose_bvar)
next
  case (abs s t bT sa ta T Ts rT )
  obtain s' where "Abs bT s' = sa"
    using abs.hyps(3) abs.prems loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 typ_of1_imp_no_loose_bvar
    by (metis length_Cons)
  moreover obtain t' where "Abs bT t' = ta"
    using abs.hyps(4) abs.prems loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 typ_of1_imp_no_loose_bvar
    by (metis length_Cons)
  ultimately have "s' \<rightarrow>\<^sub>\<beta> t'"
    by (metis abs.hyps(1) abs.hyps(3) abs.hyps(4) abs.prems(1) abs.prems(2) length_Cons
        loose_bvar_Suc no_loose_bvar_imp_no_subst_bv1 term.inject(4) typ_of1_imp_no_loose_bvar)
  then show ?case
    using \<open>Abs bT s' = sa\<close> \<open>Abs bT t' = ta\<close> by blast
qed

(* Longterm: Move to Term and unify with subst_bv2, so far only used for beta reduction *)
fun subst_bvs1' :: "term \<Rightarrow> nat \<Rightarrow> term list \<Rightarrow> term" where
  "subst_bvs1' (Bv i) lev args = (if i < lev then Bv i
    else if i - lev < length args then (nth args (i-lev))
    else Bv (i - length args))"
| "subst_bvs1' (Abs T body) lev args = Abs T (subst_bvs1' body (lev + 1) (map (\<lambda>t. lift t 0) args))"
| "subst_bvs1' (f $ t) lev u = subst_bvs1' f lev u $ subst_bvs1' t lev u"
| "subst_bvs1' t _ _ = t"

lemma subst_bvs1'_empty [simp]: "subst_bvs1' t lev [] = t"
  by (induction t lev "[]::term list" rule: subst_bvs1.induct)auto

lemma subst_bvs1'_eq [simp]: "args \<noteq> [] \<Longrightarrow> subst_bvs1' (Bv k) k args = args ! 0"
  by simp
lemma subst_bvs1'_eq' [simp]: "i < length args \<Longrightarrow> subst_bvs1' (Bv (k+i)) k args = args ! i"
  by auto

lemma subst_bvs1'_gt [simp]:
  "i + length args < j \<Longrightarrow> subst_bvs1' (Bv j) i args = Bv (j - length args)"
  by auto

lemma subst_bv2_lt [simp]: "j < i \<Longrightarrow> subst_bvs1' (Bv j) i u = Bv j"
  by simp

lemma subst_bvs1'_App[simp]: "subst_bvs1' (s$t) k args
  = subst_bvs1' s k args $ subst_bvs1' t k args"
  by simp

lemma incr_bv_incr_bv:
    "i < k + 1 \<Longrightarrow> incr_bv inc2 (k+inc1) (incr_bv inc1 i t) = incr_bv inc1 i (incr_bv inc2 k t)"
proof (induction t arbitrary: i k)
  case (Abs T t)
  then show ?case
    by (metis Suc_eq_plus1 add_Suc add_mono1 incr_bv.simps(2))
qed auto

lemma subst_bvs1_subst_bvs1': "subst_bvs1 t n s = subst_bvs1' t n (map (incr_bv n 0) s)"
proof (induction t arbitrary: n)
  case (Abs T t)
  then show ?case
    by (simp add: incr_boundvars_def incr_bv_combine)
      (metis One_nat_def comp_apply incr_bv_combine plus_1_eq_Suc)
qed (auto simp add: incr_boundvars_def incr_bv_combine)

theorem subst_bvs1_subst_bvs1'_0: "subst_bvs1 t 0 s = subst_bvs1' t 0 s"
proof-
  have "subst_bvs1 t 0 s = subst_bvs1' t 0 (map (incr_bv 0 0) s)"
    using subst_bvs1_subst_bvs1' by blast
  moreover have "map (incr_bv 0 0) s = s"
    by (induction s) auto
  ultimately show ?thesis
    by simp
qed

corollary subst_bvs_subst_bvs1': "subst_bvs s t = subst_bvs1' t 0 s"
  using subst_bvs_def subst_bvs1_subst_bvs1'_0 by simp

lemma no_loose_bvar_subst_bvs1'_unchanged: "\<not> loose_bvar t lev \<Longrightarrow> subst_bvs1' t lev args = t"
  by (induction t lev args rule: subst_bvs1'.induct) auto

(* This is enough when just substituting variables, however in the \<beta> case I will have to
  distribute subst_bvs through a single subst_bv(where the substituted term is not a var).
*)
lemma subst_bvs1'_step: "\<forall>x \<in> set (a#args) . is_closed x \<Longrightarrow>
  subst_bvs1' t lev (a#args) = subst_bvs1' (subst_bv2 t lev a) lev args"
proof (induction t lev args rule: subst_bvs1'.induct)
  case (1 i lev args)
  then show ?case
    using no_loose_bvar_subst_bvs1'_unchanged
    by (simp add: is_open_def)
      (metis Suc_diff_Suc le_add1 le_add_same_cancel1 less_antisym loose_bvar_leq not_less_eq)
qed (auto simp add: is_open_def)

lemma not_loose_bvar_incr_bv: "\<not> loose_bvar a lev \<Longrightarrow> \<not> loose_bvar (incr_bv inc lev a) (lev+inc)"
  by (induction a lev rule: loose_bvar.induct) auto

lemma not_loose_bvar_incr_bv_less:
  "i < j \<Longrightarrow> \<not> loose_bvar (incr_bv inc i a) (lev+inc) \<Longrightarrow> \<not> loose_bvar (incr_bv inc j a) (lev+inc)"
proof (induction inc i a arbitrary: lev j rule: incr_bv.induct)
  case (2 inc n T body)
  then show ?case
    by (metis Suc_eq_plus1 add_Suc add_mono1 incr_bv.simps(2) loose_bvar.simps(3))
qed (auto split: if_splits)

lemma subst_bvs1'_step_work: "\<forall>x \<in> set args . is_closed x \<Longrightarrow> \<not> loose_bvar (subst_bv2 t lev a) lev \<Longrightarrow>
  subst_bvs1' t lev (a#args) = subst_bvs1' (subst_bv2 t lev a) lev args"
proof (induction t "lev" "args" arbitrary: a rule: subst_bvs1'.induct)
  case (1 i )
  then show ?case using no_loose_bvar_subst_bvs1'_unchanged
    by (auto simp add: is_open_def)
next
  case (2 T body lev args)
  then show ?case using no_loose_bvar_subst_bvs1'_unchanged
    by (auto simp add: is_open_def)
next
  case (3 f t lev u)
  then show ?case using no_loose_bvar_subst_bvs1'_unchanged
    by (auto simp add: is_open_def)
next
  case ("4_1" v va uu uv)
  then show ?case using no_loose_bvar_subst_bvs1'_unchanged
    by (auto simp add: is_open_def)
next
  case ("4_2" v va uu uv)
  then show ?case using no_loose_bvar_subst_bvs1'_unchanged
    by (auto simp add: is_open_def)
qed

lemma is_closed_subst_bv2_unchanged: "is_closed t \<Longrightarrow> subst_bv2 t n u = t"
  by (metis is_open_def lift_def loose_bvar_Suc no_loose_bvar_no_incr subst_bv2_lift zero_induct)

(* This might do it, should be able to connect a new substitution to the pushed in one *)
lemma subst_bvs1'_step_extend_lower_level: "\<forall>x \<in> set (a#args) . is_closed x \<Longrightarrow>
  subst_bv2 (subst_bvs1' t (Suc lev) args) lev a
    = subst_bvs1' t lev (a#args)"
proof (induction t lev "a#args" arbitrary: a args rule: subst_bvs1'.induct)
  case (1 i lev)
  have "subst_bv2 (subst_bvs1' (Bv i) (Suc lev) args) lev a =
    subst_bvs1' (Bv i) lev (a # args)"
    if "i < Suc lev"
    using that by auto
  moreover have "subst_bv2 (subst_bvs1' (Bv i) (Suc lev) args) lev a =
    subst_bvs1' (Bv i) lev (a # args)"
    if "i - Suc lev < length args" "\<not> i < Suc lev"
  proof-
    have "subst_bv2 (subst_bvs1' (Bv i) (Suc lev) args) lev a = subst_bv2 (args ! (i - Suc lev)) lev a"
      using that by simp
    also have "\<dots> = args ! (i - Suc lev)"
      using 1 that(1) by (auto simp add: is_closed_subst_bv2_unchanged)
    also have "subst_bvs1' (Bv i) lev (a # args) = args ! (i - Suc lev)"
      using that by auto
    finally show ?thesis
      by simp
  qed
  moreover have "subst_bv2(subst_bvs1' (Bv i) (Suc lev) args) lev a =
    subst_bvs1' (Bv i) lev (a # args)"
    if "i \<ge> Suc lev" "i - lev \<ge> length args" "\<not> i < Suc lev"
    using that 1 by (auto simp add: is_closed_subst_bv2_unchanged)
  ultimately show ?case by (auto simp add: is_open_def split: if_splits)
qed (auto simp add: is_open_def)

corollary subst_bvs_extend_lower_level:
  "\<forall>x \<in> set (a#args) . is_closed x \<Longrightarrow>
  subst_bv a (subst_bvs1' t 1 args) = subst_bvs (a#args) t"
  using subst_bvs1'_step_extend_lower_level
  by (simp add: subst_bvs_subst_bvs1' substn_subst_0')

lemma subst_bvs1'_preserves_beta:
  "\<forall>x \<in> set u . is_closed x \<Longrightarrow> r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> subst_bvs1' r k u \<rightarrow>\<^sub>\<beta> subst_bvs1' s k u"
proof (induction u arbitrary: r s )
  case Nil
  then show ?case by auto
next
  case (Cons a u)
  hence "subst_bv2 r k a \<rightarrow>\<^sub>\<beta> subst_bv2 s k a"
    by simp
  hence "subst_bvs1' (subst_bv2 r k a) k u \<rightarrow>\<^sub>\<beta> subst_bvs1' (subst_bv2 s k a) k u"
    using Cons by simp
  then show ?case
    by (simp add: subst_bvs1'_step[symmetric] Cons.prems(1))
qed

lemma subst_bvs1'_fold: "\<forall>x \<in> set args . is_closed x \<Longrightarrow>
  subst_bvs1' t lev args = fold (\<lambda>arg t . subst_bv2 t lev arg) args t"
  by (induction args arbitrary: t) (simp_all add: subst_bvs1'_step)

lemma subst_bvs1'_Abs[simp]: "\<forall>x \<in> set args . is_closed x \<Longrightarrow>
  subst_bvs1' (Abs T t) lev args = Abs T (subst_bvs1' t (Suc lev) args)"
  by (simp add: is_open_def map_idI)

lemma subst_bvs_Abs[simp]: "\<forall>x \<in> set args . is_closed x \<Longrightarrow>
  subst_bvs args (Abs T t) = Abs T (subst_bvs1' t 1 args)"
  using subst_bvs1'_Abs subst_bvs_subst_bvs1'  by auto

lemma subst_bvs1'_incr_bv [simp]:
    "subst_bvs1' (incr_bv (length ss) k t) k ss = t"
proof (induct t arbitrary: k ss)
  case (Abs T t)
  then show ?case
    by simp (metis length_map)
qed auto

lemma lift_subst_bvs1' [simp]:
    "j < i + 1 \<Longrightarrow> lift (subst_bvs1' t j ss) i
    = subst_bvs1' (lift t (i + length ss)) j (map (\<lambda>s . lift s i) ss)"
proof (induct  t arbitrary: i j ss)
  case (Abs T t)
  hence I: "lift (subst_bvs1' t (Suc j) (map (\<lambda>t. lift t 0) ss)) (Suc i) =
    subst_bvs1' (lift t (Suc i + length (map (\<lambda>t. lift t 0) ss))) (Suc j) (map (\<lambda>a. lift a (Suc i)) (map (\<lambda>t. lift t 0) ss))"
    by auto

  have "lift (subst_bvs1' (Abs T t) j ss) i
    = Abs T (lift (subst_bvs1' t (Suc j) (map (\<lambda>t. lift t 0) ss)) (Suc i))"
    by simp
  also have "\<dots> = Abs T
     (subst_bvs1' (lift t (Suc i + length (map (incr_bv 1 0) ss))) (Suc j)
       (map (incr_bv 1 (Suc i)) (map (incr_bv 1 0) ss)))"
    using I by auto
  also have "\<dots> = Abs T
     (subst_bvs1' (lift t (Suc i + length (map (incr_bv 1 0) ss))) (Suc j)
       (map (\<lambda>t. lift t 0) (map (\<lambda>t. lift t i) ss)))"
  proof-
    have "map (\<lambda>t . lift t (Suc i)) (map (\<lambda>t. lift t 0) ss) = map (\<lambda>t. lift t 0) (map (\<lambda>t. lift t i) ss)"
      using lift_lift by auto
    thus ?thesis unfolding lift_def
      by argo
  qed
  also have "\<dots> = subst_bvs1' (Abs T (lift t (Suc i + length (map (incr_bv 1 0) ss)))) j
       (map (\<lambda>t. lift t i) ss)"
    by auto
  finally show ?case
    by simp
qed (auto simp add: diff_Suc lift_lift split: nat.split)

lemma lift_subst_bvs1'_lt:
    "i < j + 1 \<Longrightarrow> lift (subst_bvs1' t j ss) i
  = subst_bvs1' (lift t i) (j + 1) (map (\<lambda>s . lift s i) ss)"
proof (induct t arbitrary: i j ss)
  case (Abs T t)
  then show ?case using lift_lift
    by simp (smt comp_apply map_eq_conv zero_less_Suc)
qed auto

lemma subst_bvs1'_subst_bv2:
  "i < j + 1 \<Longrightarrow>
    subst_bv2(subst_bvs1' t (Suc j) (map (\<lambda>v. lift v i) vs)) i (subst_bvs1' u j vs)
    = subst_bvs1' (subst_bv2 t i u) j vs"
proof(induction t arbitrary: i j u vs)
  case (Abs T t)
  then show ?case
    by simp (smt One_nat_def Suc_eq_plus1 Suc_less_eq comp_apply lift_lift lift_def
        lift_subst_bvs1'_lt map_eq_conv map_map zero_less_Suc)
qed (use subst_bv2_lift in auto)

lemma fv_subst_bv2_upper_bound: "fv (subst_bv2 t lev u) \<subseteq> fv t \<union> fv u"
  by (induction t lev u rule: subst_bv2.induct) auto
lemma beta_fv: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> fv t \<subseteq> fv s"
  by (induction rule: beta.induct) (use fv_subst_bv2_upper_bound in auto)

lemma loose_bvar1_subst_bvs1'_closeds: "\<not> loose_bvar1 t lev \<Longrightarrow> lev < k \<Longrightarrow> \<forall>x\<in>set us . is_closed x
  \<Longrightarrow> \<not> loose_bvar1 (subst_bvs1' t k us) lev"
  by (induction t k us arbitrary: lev rule: subst_bvs1'.induct)
    (use is_open_def loose_bvar_iff_exist_loose_bvar1 in \<open>auto simp add: is_open_def\<close>)

lemma is_closed_subst_bvs1'_closeds: "\<not> is_dependent t \<Longrightarrow> \<forall>x\<in>set us . is_closed x
  \<Longrightarrow> \<not> is_dependent (subst_bvs1' t (Suc k) us)"
  by (simp add: is_dependent_def loose_bvar1_subst_bvs1'_closeds)

end