(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Set Implementation by List with explicit invariants} *}
theory ListSetImpl_Invar
  imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Dlist_add"
begin
text_raw {*\label{thy:ListSetImpl_Invar}*}

(*@impl Set
  @type 'a lsi
  @abbrv lsi,l
  Sets by lists with distinct elements. Version with explicit invariant that
  supports efficient @{text "insert_dj"} operation.
*)

type_synonym
  'a lsi = "'a list"

subsection "Definitions"

definition lsi_ins :: "'a \<Rightarrow> 'a lsi \<Rightarrow> 'a lsi" where "lsi_ins x l == if  List.member l x then l else x#l"

definition lsi_basic_ops :: "('a,'a lsi) set_basic_ops" where
  [icf_rec_def]: "lsi_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = set,
    bset_op_invar = distinct,
    bset_op_empty = \<lambda>_. [],
    bset_op_memb = (\<lambda>x s. List.member s x),
    bset_op_ins = lsi_ins,
    bset_op_ins_dj = op #,
    bset_op_delete = \<lambda>x l. Dlist_add.dlist_remove1' x [] l,
    bset_op_list_it = foldli
    \<rparr>"

setup Locale_Code.open_block
interpretation lsi_basic: StdBasicSet lsi_basic_ops
  apply unfold_locales
  unfolding lsi_basic_ops_def lsi_ins_def[abs_def]
  apply (auto simp: List.member_def set_dlist_remove1'
  distinct_remove1')
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsi_ops \<equiv> lsi_basic.dflt_ops \<lparr>
  set_op_union_dj := op @,
  set_op_to_list := id
\<rparr>"

setup Locale_Code.open_block
interpretation lsi: StdSet lsi_ops
proof -
  interpret aux: StdSet lsi_basic.dflt_ops by (rule lsi_basic.dflt_ops_impl)

  show "StdSet lsi_ops"
    unfolding lsi_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales, auto)
    done
qed
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lsi"*}

lemma pi_lsi[proper_it]:
  "proper_it' foldli foldli"
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lsi: proper_it_loc foldli foldli
  apply unfold_locales by (rule pi_lsi)

definition test_codegen where "test_codegen \<equiv> (
  lsi.empty,
  lsi.memb,
  lsi.ins,
  lsi.delete,
  lsi.list_it,
  lsi.sng,
  lsi.isEmpty,
  lsi.isSng,
  lsi.ball,
  lsi.bex,
  lsi.size,
  lsi.size_abort,
  lsi.union,
  lsi.union_dj,
  lsi.diff,
  lsi.filter,
  lsi.inter,
  lsi.subset,
  lsi.equal,
  lsi.disjoint,
  lsi.disjoint_witness,
  lsi.sel,
  lsi.to_list,
  lsi.from_list
)"

export_code test_codegen in SML

end


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

theory Pair_Digraph
imports
  Digraph
  Bidirected_Digraph
  Arc_Walk
begin

section \<open>Digraphs without Parallel Arcs\<close>

text \<open>
  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.
\<close>

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 \<open>(x,y) \<in> set p\<close> obtain p1 p2 where p_decomp: "p = p1 @ (x,y) # p2"
    by (metis (no_types) in_set_conv_decomp_first)
  from p_decomp \<open>apath u p v\<close> \<open>y \<noteq> v\<close> 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 \<open>apath u p v\<close>
    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 \<open>Path reversal for Pair Digraphs\<close>

text \<open>This definition is only meaningful in @{term Pair_Digraph}\<close>

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 \<open>Subdividing Edges\<close>

text \<open>subdivide an edge (=two associated arcs) in graph\<close>
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 \<open>subdivide an arc in a path\<close>
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 \<open>contract an arc in a path\<close>
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 \<open>e = _\<close> 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
  define sG where "sG = 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 \<open>u \<noteq> w\<close> 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 \<open>u = a\<close> 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 \<open>fst e1 \<noteq> w\<close> e_w by (auto simp add: e_conv)
      moreover
      have "fst e2 = w" using \<open>snd e1 = w\<close> 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 \<open>fst e2 = w\<close> 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 \<open>fst e1 \<noteq> w\<close> 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 \<open>snd e1 \<noteq> w\<close> 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 \<open>e1 \<in> parcs G\<close> 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 \<open>fst e1 \<noteq> w\<close> 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


(* Copyright 2020 (C) Mihails Milehins *)

section\<open>Smallness for orders\<close>
theory CZH_ECAT_Small_Order
  imports
    CZH_ECAT_Order
    CZH_ECAT_Small_Functor
begin

subsection\<open>Background\<close>

named_theorems cat_small_order_cs_simps
named_theorems cat_small_order_cs_intros

subsection\<open>Tiny preorder category\<close>

locale cat_tiny_preorder = tiny_category \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_tiny_peo:
    "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow>
      (\<exists>f. Hom \<CC> a b = set {f}) \<or> (Hom \<CC> a b = 0)"

text\<open>Rules.\<close>

lemma (in cat_tiny_preorder) cat_tiny_preorder_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_tiny_preorder \<alpha>' \<CC>"
  unfolding assms by (rule cat_tiny_preorder_axioms)

mk_ide rf cat_tiny_preorder_def[unfolded cat_tiny_preorder_axioms_def]
  |intro cat_tiny_preorderI|
  |dest cat_tiny_preorderD[dest]|
  |elim cat_tiny_preorderE[elim]|

lemmas [cat_small_order_cs_intros] = cat_tiny_preorderD(1)

text\<open>Tiny preorder is a preorder.\<close>

sublocale cat_tiny_preorder \<subseteq> cat_preorder
  by (intro cat_preorderI cat_tiny_peo category_axioms) simp_all

lemmas (in cat_tiny_preorder) cat_tiny_peo_is_cat_preoder = cat_preorder_axioms

lemmas [cat_small_order_cs_intros] =
  cat_tiny_preorder.cat_tiny_peo_is_cat_preoder

subsection\<open>Tiny partial order category\<close>

locale cat_tiny_partial_order = cat_tiny_preorder \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_tiny_po:
    "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b; b \<le>\<^sub>O\<^bsub>\<CC>\<^esub> a \<rbrakk> \<Longrightarrow> a = b"

text\<open>Rules.\<close>

lemma (in cat_tiny_partial_order)
  cat_tiny_partial_order_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_tiny_partial_order \<alpha>' \<CC>"
  unfolding assms by (rule cat_tiny_partial_order_axioms)

mk_ide rf cat_tiny_partial_order_def[unfolded cat_tiny_partial_order_axioms_def]
  |intro cat_tiny_partial_orderI|
  |dest cat_tiny_partial_orderD[dest]|
  |elim cat_tiny_partial_orderE[elim]|

lemmas [cat_small_order_cs_intros] = cat_tiny_partial_orderD(1)

text\<open>Tiny partial order is a partial order.\<close>

sublocale cat_tiny_partial_order \<subseteq> cat_partial_order
  by (intro cat_partial_orderI cat_tiny_po cat_preorder_axioms) simp_all

lemmas (in cat_tiny_preorder) cat_tiny_po_is_cat_preoder = cat_preorder_axioms

lemmas [cat_small_order_cs_intros] =
  cat_tiny_preorder.cat_tiny_peo_is_cat_preoder

lemma cat_tiny_partial_orderI':
  assumes "tiny_category \<alpha> \<CC>"
    and "cat_partial_order \<alpha> \<CC>"
  shows "cat_tiny_partial_order \<alpha> \<CC>"
proof-
  interpret tiny_category \<alpha> \<CC> by (rule assms(1))
  interpret cat_partial_order \<alpha> \<CC> by (rule assms(2))
  show ?thesis
    by (intro cat_tiny_partial_orderI cat_tiny_preorderI assms(1) cat_po cat_peo)
qed

subsection\<open>Tiny linear order category\<close>

locale cat_tiny_linear_order = cat_tiny_partial_order \<alpha> \<CC> for \<alpha> \<CC> +
  assumes cat_tiny_lo: "\<lbrakk> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<rbrakk> \<Longrightarrow> a \<le>\<^sub>O\<^bsub>\<CC>\<^esub> b \<or> b \<le>\<^sub>O\<^bsub>\<CC>\<^esub> a"

text\<open>Rules.\<close>

lemma (in cat_tiny_linear_order)
  cat_tiny_linear_order_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "cat_tiny_linear_order \<alpha>' \<CC>"
  unfolding assms by (rule cat_tiny_linear_order_axioms)

mk_ide rf cat_tiny_linear_order_def[unfolded cat_tiny_linear_order_axioms_def]
  |intro cat_tiny_linear_orderI|
  |dest cat_tiny_linear_orderD[dest]|
  |elim cat_tiny_linear_orderE[elim]|

lemmas [cat_small_order_cs_intros] = cat_tiny_linear_orderD(1)

text\<open>Tiny linear order is a partial order.\<close>

sublocale cat_tiny_linear_order \<subseteq> cat_linear_order
  by (intro cat_linear_orderI cat_tiny_lo cat_partial_order_axioms) simp_all

lemmas (in cat_tiny_linear_order) cat_tiny_lo_is_cat_partial_order =
  cat_linear_order_axioms

lemmas [cat_small_order_cs_intros] =
  cat_tiny_linear_order.cat_tiny_lo_is_cat_partial_order

lemma cat_tiny_linear_orderI':
  assumes "tiny_category \<alpha> \<CC>" and "cat_linear_order \<alpha> \<CC>"
  shows "cat_tiny_linear_order \<alpha> \<CC>"
proof-
  interpret tiny_category \<alpha> \<CC> by (rule assms(1))
  interpret cat_linear_order \<alpha> \<CC> by (rule assms(2))
  show ?thesis
    by
      (
        intro
          assms(1)
          cat_tiny_linear_orderI
          cat_tiny_partial_orderI'
          cat_partial_order_axioms
          cat_lo
      )
qed

subsection\<open>Tiny preorder functor\<close>

locale is_tiny_preorder_functor =
  is_functor \<alpha> \<AA> \<BB> \<FF> +
  HomDom: cat_tiny_preorder \<alpha> \<AA> +
  HomCod: cat_tiny_preorder \<alpha> \<BB>
  for \<alpha> \<AA> \<BB> \<FF>

syntax "_is_tiny_preorder_functor" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<index> _)\<close> [51, 51, 51] 51)
translations "\<FF> : \<AA> \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons>
  "CONST is_tiny_preorder_functor \<alpha> \<AA> \<BB> \<FF>"

text\<open>Rules.\<close>

lemma (in is_tiny_preorder_functor)
  is_tiny_preorder_functor_axioms'[cat_order_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>"
  shows "\<FF> : \<AA>' \<le>\<^sub>C\<^sub>.\<^sub>P\<^sub>E\<^sub>O\<^sub>.\<^sub>t\<^sub>i\<^sub>n\<^sub>y\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tiny_preorder_functor_axioms)

mk_ide rf is_tiny_preorder_functor_def
  |intro is_tiny_preorder_functorI|
  |dest is_tiny_preorder_functorD[dest]|
  |elim is_tiny_preorder_functorE[elim]|

lemmas [cat_small_order_cs_intros] = is_tiny_preorder_functorD(1)

text\<open>Tiny preorder functor is a tiny functor\<close>

sublocale is_tiny_preorder_functor \<subseteq> is_tiny_functor
  by
    (
      intro
        is_tiny_functorI'
        is_functor_axioms
        HomDom.tiny_category_axioms
        HomCod.tiny_category_axioms
    )

end


theory Submission
  imports Defs
begin

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (Loop c b) =
 (let cc = ccomp c; cb = bcomp b False 1
  in cc @ cb @ [JMP (-(size cc + size cb + 1))])"

value "ccomp (Loop (''u'' ::= Plus (V ''u'') (N 1)) (Less (N 0) (V ''u'')))"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
  proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (LoopTrue c s1 s2 b s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False 1"
  let ?cl = "ccomp(Loop c b)"
  have "?cl \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc,s2,stk)"
    by (simp add: LoopTrue.IH(1) exec_appendR)
  moreover
  have "?cl \<turnstile> (size ?cc,s2,stk) \<rightarrow>* (size ?cc + size ?cb,s2,stk)"
    using \<open>bval b s2\<close> by fastforce
  moreover
  have "?cl \<turnstile> (size ?cc + size ?cb,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cl \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cl,s3,stk)" by(rule LoopTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


header {* Generic Algorithms for Graphs *}
theory GraphGA
imports
  GraphSpec
begin

  definition gga_from_list ::
    "('V,'W,'G) graph_empty \<Rightarrow> ('V,'W,'G) graph_add_node
      \<Rightarrow> ('V,'W,'G) graph_add_edge
    \<Rightarrow> ('V,'W,'G) graph_from_list"
    where
    "gga_from_list e a u l \<equiv>
      let (nl,el) = l;
        g1 = foldl (\<lambda>g v. a v g) (e ()) nl
      in foldl (\<lambda>g (v,e,v'). u v e v' g) g1 el"

  lemma gga_from_list_correct:
    fixes \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    assumes "graph_empty \<alpha> invar e"
    assumes "graph_add_node \<alpha> invar a"
    assumes "graph_add_edge \<alpha> invar u"
    shows "graph_from_list \<alpha> invar (gga_from_list e a u)"
  proof -
    interpret
      graph_empty \<alpha> invar e +
      graph_add_node \<alpha> invar a +
      graph_add_edge \<alpha> invar u
      by fact+

    {
      fix nl el
      def g1\<equiv>"(foldl (\<lambda>g v. a v g) (e ()) nl)"
      def g2\<equiv>"(foldl (\<lambda>g (v,e,v'). u v e v' g) g1 el)"
      have "invar g1 \<and> \<alpha> g1 = \<lparr> nodes = set nl, edges = {} \<rparr>"
        unfolding g1_def
        by (induct nl rule: rev_induct)
           (auto simp: empty_correct add_node_correct empty_def add_node_def)
      hence "invar g2
        \<and> \<alpha> g2 = \<lparr> nodes = set nl \<union> fst`set el \<union> snd`snd`set el,
                    edges = set el \<rparr>"
        unfolding g2_def
        by (induct el rule: rev_induct) (auto simp: add_edge_correct add_edge_def)
      hence "invar g2 \<and> adjl_\<alpha> (nl,el) = \<alpha> g2"
        unfolding adjl_\<alpha>_def by auto
    }
    thus ?thesis
      unfolding gga_from_list_def [abs_def]
      apply unfold_locales
      apply auto
      done
  qed

  term map_iterator_product

  locale gga_edges_it_defs =
    graph_nodes_it_defs nodes_list_it +
    graph_succ_it_defs succ_list_it
    for nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and succ_list_it :: "('V,'W,('W\<times>'V) list,'G) graph_succ_it"
  begin
    definition gga_edges_list_it ::
      "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
      where "gga_edges_list_it G \<equiv> set_iterator_product
        (nodes_it G) (succ_it G)"
    local_setup {* Locale_Code.lc_decl_del @{term gga_edges_list_it} *}
  end
  setup {*
    (Record_Intf.add_unf_thms_global @{thms
      gga_edges_it_defs.gga_edges_list_it_def[abs_def]
    })
  *}

  locale gga_edges_it = gga_edges_it_defs nodes_list_it succ_list_it
    + graph \<alpha> invar
    + graph_nodes_it \<alpha> invar nodes_list_it
    + graph_succ_it \<alpha> invar succ_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    and invar
    and nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and succ_list_it :: "('V,'W,('W\<times>'V) list,'G) graph_succ_it"
  begin
    lemma gga_edges_list_it_impl:
      shows "graph_edges_it \<alpha> invar gga_edges_list_it"
    proof
      fix g
      assume INV: "invar g"

      from set_iterator_product_correct[OF
        nodes_it_correct[OF INV] succ_it_correct[OF INV]]
      have "set_iterator (set_iterator_product (nodes_it g) (\<lambda>v. succ_it g v))
        (SIGMA v:nodes (\<alpha> g). succ (\<alpha> g) v)
        " .
      also have "(SIGMA v:nodes (\<alpha> g). succ (\<alpha> g) v) = edges (\<alpha> g)"
        unfolding succ_def
        by (auto dest: valid_graph.E_validD[OF valid[OF INV]])

      finally show "set_iterator (gga_edges_list_it g) (edges (\<alpha> g))"
        unfolding gga_edges_list_it_def .
    qed
  end

  locale gga_to_list_defs_loc =
    graph_nodes_it_defs nodes_list_it
    + graph_edges_it_defs edges_list_it
    for nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin
    definition gga_to_list ::
      "('V,'W,'G) graph_to_list"
      where
      "gga_to_list g \<equiv>
        (nodes_it g (\<lambda>_. True) (op #) [], edges_it g (\<lambda>_. True) (op #) [])
      "
  end

  locale gga_to_list_loc = gga_to_list_defs_loc nodes_list_it edges_list_it +
    graph \<alpha> invar
    + graph_nodes_it \<alpha> invar nodes_list_it
    + graph_edges_it \<alpha> invar edges_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar
    and nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin

    lemma gga_to_list_correct:
      shows "graph_to_list \<alpha> invar gga_to_list"
    proof
      fix g
      assume [simp, intro!]: "invar g"
      then interpret valid_graph "\<alpha> g" by (rule valid)

      have "set (nodes_it g (\<lambda>_. True) (op #) []) = V"
        apply (rule_tac I="\<lambda>it \<sigma>. set \<sigma> = V - it"
          in set_iterator_rule_P[OF nodes_it_correct])
        by auto
      moreover have "set (edges_it g (\<lambda>_. True) (op #) []) = E"
        apply (rule_tac I="\<lambda>it \<sigma>. set \<sigma> = E - it"
          in set_iterator_rule_P[OF edges_it_correct])
        by auto
      ultimately show "adjl_\<alpha> (gga_to_list g) = \<alpha> g"
        unfolding adjl_\<alpha>_def gga_to_list_def
        apply simp
        apply (rule graph.equality)
        apply (auto intro: E_validD)
        done
    qed

  end

end


(*
 *
 * Copyright 2017, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)
theory Strengthen_Demo

imports "Strengthen"

begin

text \<open>Here's a complicated predicate transformer. You don't need
to understand this, it just makes it easy to set up some complicated
example goals below.\<close>
definition
  "predt f g h P x y = (\<exists>x'. (\<exists>y' \<in> f y. x' \<in> g y' ` h y) \<and> P x x')"

text \<open>Strengthen performs the same kinds of steps as
intro/elim rules, but it can perform them within complex
conclusions. Here's an example where we replace Q with P
(strengthening the goal) deep within some quantifiers.\<close>

lemma predt_double_mono:
  assumes PQ: "\<And>x y. P x y \<longrightarrow> Q x y"
  assumes P: "predt f g h (predt f g h' P) x y"
  shows "predt f g h (predt f g h' Q) x y"
  using P
  apply (simp add: predt_def)
  apply (strengthen PQ)
  apply assumption
  done

text \<open>Here's a more conventional monotonicity proof.
Once the clarsimp has finished, the goal becomes a bit
difficult to prove. Let's use some fancy strengthen
features to address this. The rest of this demo will
explain what the attribute and fancy features are doing,
and thus how this proof works.\<close>

lemma predt_double_mono2:
  assumes PQ: "\<And>x y. P x y \<longrightarrow> Q x y"
  assumes P: "predt f g h (predt f g' h P) x y"
  shows "predt f g h (predt f g' h Q) x y"
  using P
  apply (clarsimp simp: predt_def)
  apply (strengthen bexI[mk_strg I _ A])
  apply (strengthen image_eqI[mk_strg I _ A])
  apply simp
  apply (strengthen bexI[mk_strg I _ O], assumption)
  apply (strengthen image_eqI[mk_strg I _ E])
  apply simp
  apply (simp add: PQ)
  done

text \<open>The @{attribute mk_strg} controls the way that
strengthen applies a rule. By default, strengthen will
use a rule as an introduction rule, trying to replace
the rule's conclusion with its premises.

Once the @{attribute mk_strg} attribute has applied, the
rule is formatted showing how strengthen will try to
transform components of a goal. The syntax of the
second theorem is reversed, showing that strengthen will
attempt to replace instances of the subset predicate
with instances of the proper subset predicate.
\<close>
thm psubset_imp_subset psubset_imp_subset[mk_strg]

text \<open>Rules can have any number of premises, or none,
and still be used as strengthen rules.\<close>
thm subset_UNIV subset_UNIV[mk_strg]
    equalityI equalityI[mk_strg]

text \<open>Rules which would introduce schematics are
adjusted by @{attribute mk_strg} to introduce quantifiers
instead. The argument I to mk_strg prevents this step.
\<close>
thm subsetD subsetD[mk_strg I] subsetD[mk_strg]

text \<open>The first argument to mk_strg controls the way
the rule will be applied.
  I: use rule in introduction style, matching its conclusion.
  D: use rule in destruction (forward) style, matching its first premise.
  I': like I, replace new schematics with existential quantifiers.
  D': like D, replace new schematics with universal quantifiers.

The default is I'.
\<close>
thm subsetD subsetD[mk_strg I] subsetD[mk_strg I']
  subsetD[mk_strg D] subsetD[mk_strg D']

text \<open>Note that I and D rules will be applicable at different
sites.\<close>
lemma
  assumes PQ: "P \<Longrightarrow> Q"
  shows "{x. Suc 0 < x \<and> P} \<subseteq> {x. Suc 0 < x \<and> Q}"
  (* adjust Q into P on rhs *)
  apply (strengthen PQ[mk_strg I])
  (* adjust P into Q on lhs *)
  apply (strengthen PQ[mk_strg D])
  (* oops, overdid it *)
  oops

text \<open>Subsequent arguments to mk_strg capture premises for
special treatment. The 'A' argument (synonym 'E') specifies that
a premise should be solved by assumption. Our fancy proof above
used a strengthen rule bexI[mk_strg I _ A], which tells strengthen
to do approximately the same thing as
\<open>apply (rule bexI) prefer 2 apply assumption\<close>

This is a useful way to apply a rule, picking the premise which
will cause unknowns to be instantiated correctly.
\<close>
thm eq_mem_trans eq_mem_trans[mk_strg I _ _] eq_mem_trans[mk_strg I A _]
    eq_mem_trans[mk_strg I _ A] eq_mem_trans[mk_strg I A A]

text \<open>The 'O' argument ("obligation") picks out premises of
a rule for immediate attention as new subgoals.

The step
\<open>apply (strengthen bexI[mk_strg I _ O], assumption)\<close>
in our proof above had the same effect as strengthening with
@{thm bexI[mk_strg I _ A]}.

This option suits special cases where a particular premise is best
handled by a specialised method.
\<close>
thm eq_mem_trans eq_mem_trans[mk_strg I _ _] eq_mem_trans[mk_strg I O _]
    eq_mem_trans[mk_strg I _ O] eq_mem_trans[mk_strg I O O]

end


theory SINVAR_Dependability_impl
imports SINVAR_Dependability "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_Dependability_impl => (Scala) SINVAR_Dependability

subsubsection {* SecurityInvariant Dependability List Implementation *}

text {* Less-equal other nodes depend on the output of a node than its dependability level. *}
fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> set (edgesL G). (num_reachable G e1) \<le> (nP e1))"

fun verify_globals :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> unit \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 3)"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 2)"

text{* Generate a valid configuration to start from: *}
   fun fix_nP :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "fix_nP G nP = (\<lambda>v. let nr = num_reachable G v in (if nr \<le> (nP v) then (nP v) else nr))"

   theorem fix_nP_impl_correct: "valid_list_graph G \<Longrightarrow> fix_nP G nP  = SINVAR_Dependability.fix_nP (list_graph_to_graph G) nP"
   by(simp add: num_reachable_correct fun_eq_iff)

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1), (2,1), (3,1), (4,1), (1,2), (1,3)] \<rparr> in (let nP = fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1)] \<rparr> in (let nP = fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

definition Dependability_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<times> 'v) list list" where
  "Dependability_offending_list = Generic_offending_list sinvar"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_Dependability.default_node_properties))"

definition "Dependability_eval G P = (valid_list_graph G \<and>
  verify_globals G (SecurityInvariant.node_props SINVAR_Dependability.default_node_properties P) (model_global_properties P) \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_Dependability.default_node_properties P))"

lemma sinvar_correct: "valid_list_graph G \<Longrightarrow> SINVAR_Dependability.sinvar (list_graph_to_graph G) nP = sinvar G nP"
   apply(simp)
   apply(rule all_edges_list_I)
   apply(simp add: fun_eq_iff)
   apply(clarify)
   apply(rename_tac x)
   apply(drule_tac v="x" in  num_reachable_correct)
  apply presburger
done

interpretation Dependability_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_Dependability.default_node_properties
  and sinvar_spec=SINVAR_Dependability.sinvar
  and sinvar_impl=sinvar
  and verify_globals_spec=SINVAR_Dependability.verify_globals
  and verify_globals_impl=verify_globals
  and receiver_violation=SINVAR_Dependability.receiver_violation
  and offending_flows_impl=Dependability_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=Dependability_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_Dependability)
  apply(rule conjI)
   apply(intro allI impI)
   apply(fact sinvar_correct)
  apply(simp)
 apply(rule conjI)
  apply(unfold Dependability_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis Dependability.node_props.simps Dependability.node_props_eq_node_props_formaldef)
 apply(simp only: Dependability_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_Dependability])
  apply(simp only: sinvar_correct)
 apply(simp)
done

subsubsection {* Dependability packing *}
  definition SINVAR_LIB_Dependability :: "('v::vertex, SINVAR_Dependability.dependability_level, unit) TopoS_packed" where
    "SINVAR_LIB_Dependability \<equiv>
    \<lparr> nm_name = ''Dependability'',
      nm_receiver_violation = SINVAR_Dependability.receiver_violation,
      nm_default = SINVAR_Dependability.default_node_properties,
      nm_sinvar = sinvar,
      nm_verify_globals = verify_globals,
      nm_offending_flows = Dependability_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = Dependability_eval
      \<rparr>"
  interpretation SINVAR_LIB_Dependability_interpretation: TopoS_modelLibrary SINVAR_LIB_Dependability
      SINVAR_Dependability.sinvar SINVAR_Dependability.verify_globals
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_Dependability_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text {*Example: *}
  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=3, 2:=2, 3:=1, 4:=0, 8:=2, 9:=2, 10:=0))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=10, 2:=10, 3:=10, 4:=10, 8:=10, 9:=10, 10:=10))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. 2))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in Dependability_eval G  \<lparr>node_properties=[1\<mapsto>3, 2\<mapsto>2, 3\<mapsto>1, 4\<mapsto>0, 8\<mapsto>2, 9\<mapsto>2, 10\<mapsto>0], model_global_properties=() \<rparr>"

  value "Dependability_offending_list \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> (\<lambda> n. 2)"

hide_fact (open) sinvar_correct
hide_const (open) sinvar verify_globals NetModel_node_props

end


subsection\<open>Consistency\<close>

text\<open>We follow the proofs by Melvin Fitting~\<^cite>\<open>"fitting1990first"\<close>.\<close>
theory Consistency
imports Sema
begin

definition "Hintikka S \<equiv> (
  \<bottom> \<notin> S
\<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
\<and> (\<forall>F G. F \<^bold>\<and> G \<in> S \<longrightarrow> F \<in> S \<and> G \<in> S)
\<and> (\<forall>F G. F \<^bold>\<or> G \<in> S \<longrightarrow> F \<in> S \<or> G \<in> S)
\<and> (\<forall>F G. F \<^bold>\<rightarrow> G \<in> S \<longrightarrow> \<^bold>\<not>F \<in> S \<or> G \<in> S)
\<and> (\<forall>F. \<^bold>\<not> (\<^bold>\<not>F) \<in> S \<longrightarrow> F \<in> S)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<and> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<in> S \<or> \<^bold>\<not> G \<in> S)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<or> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<in> S \<and> \<^bold>\<not> G \<in> S)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G) \<in> S \<longrightarrow> F \<in> S \<and> \<^bold>\<not> G \<in> S)
)"

lemma "Hintikka {Atom 0 \<^bold>\<and> ((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), ((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), Atom 0, \<^bold>\<not>(\<^bold>\<not> (Atom 1)), Atom 1}"
  unfolding Hintikka_def by simp

theorem Hintikkas_lemma:
  assumes H: "Hintikka S"
  shows "sat S"
proof -
  from H[unfolded Hintikka_def]
  have H': "\<bottom> \<notin> S"
    "Atom k \<in> S \<Longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<Longrightarrow> False"
    "F \<^bold>\<and> G \<in> S \<Longrightarrow> F \<in> S \<and> G \<in> S"
    "F \<^bold>\<or> G \<in> S \<Longrightarrow> F \<in> S \<or> G \<in> S"
    "F \<^bold>\<rightarrow> G \<in> S \<Longrightarrow> \<^bold>\<not>F \<in> S \<or> G \<in> S"
    "\<^bold>\<not> (\<^bold>\<not> F) \<in> S \<Longrightarrow> F \<in> S"
    "\<^bold>\<not> (F \<^bold>\<and> G) \<in> S \<Longrightarrow> \<^bold>\<not> F \<in> S \<or> \<^bold>\<not> G \<in> S"
    "\<^bold>\<not> (F \<^bold>\<or> G) \<in> S \<Longrightarrow> \<^bold>\<not> F \<in> S \<and> \<^bold>\<not> G \<in> S"
    "\<^bold>\<not> (F \<^bold>\<rightarrow> G) \<in> S \<Longrightarrow> F \<in> S \<and> \<^bold>\<not> G \<in> S"
    for k F G by blast+
  let ?M = "\<lambda>k. Atom k \<in> S"
  have "(F \<in> S \<longrightarrow> (?M \<Turnstile> F)) \<and> (\<^bold>\<not> F \<in> S \<longrightarrow> (\<not>(?M \<Turnstile> F)))" for F
    by(induction F) (auto simp: H'(1) dest!: H'(2-))
  thus ?thesis unfolding sat_def by blast
qed

definition "pcp C \<equiv> (\<forall>S \<in> C.
  \<bottom> \<notin> S
\<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
\<and> (\<forall>F G. F \<^bold>\<and> G \<in> S \<longrightarrow> F \<triangleright> G \<triangleright> S \<in> C)
\<and> (\<forall>F G. F \<^bold>\<or> G \<in> S \<longrightarrow> F \<triangleright> S \<in> C \<or> G \<triangleright> S \<in> C)
\<and> (\<forall>F G. F \<^bold>\<rightarrow> G \<in> S \<longrightarrow> \<^bold>\<not>F \<triangleright> S \<in> C \<or> G \<triangleright> S \<in> C)
\<and> (\<forall>F. \<^bold>\<not> (\<^bold>\<not>F) \<in> S \<longrightarrow> F \<triangleright> S \<in> C)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<and> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<triangleright> S \<in> C \<or> \<^bold>\<not> G \<triangleright> S \<in> C)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<or> G) \<in> S \<longrightarrow> \<^bold>\<not> F \<triangleright> \<^bold>\<not> G \<triangleright> S \<in> C)
\<and> (\<forall>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G) \<in> S \<longrightarrow> F \<triangleright> \<^bold>\<not> G \<triangleright> S \<in> C)
)"

(* just some examples *)
lemma "pcp {}" "pcp {{}}" "pcp {{Atom 0}}" by (simp add: pcp_def)+
lemma "pcp {{(\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2},
   {((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), \<^bold>\<not>(\<^bold>\<not> (Atom 1))},
  {((\<^bold>\<not> (Atom 1)) \<^bold>\<rightarrow> Atom 2), \<^bold>\<not>(\<^bold>\<not> (Atom 1)),  Atom 1}}" by (auto simp add: pcp_def)

text\<open>Fitting uses uniform notation~\<^cite>\<open>"smullyan1963unifying"\<close> for the definition of @{const pcp}.
We try to mimic this, more to see whether it works than because it is ultimately necessary.\<close>
(* It does help a bit, occasionally. *)

inductive Con :: "'a formula => 'a formula => 'a formula => bool" where
"Con (And F G) F G" |
"Con (Not (Or F G)) (Not F) (Not G)" |
"Con (Not (Imp F G)) F (Not G)" |
"Con (Not (Not F)) F F"

inductive Dis :: "'a formula => 'a formula => 'a formula => bool" where
"Dis (Or F G) F G" |
"Dis (Imp F G) (Not F) G" |
"Dis (Not (And F G)) (Not F) (Not G)" |
"Dis (Not (Not F)) F F"

(* note that *)
lemma "Con (Not (Not F)) F F" "Dis (Not (Not F)) F F" by(intro Con.intros Dis.intros)+
(* i.e. \<^bold>\<not>\<^bold>\<not> is both Conjunctive and Disjunctive. I saw no reason to break this symmetry. *)

lemma con_dis_simps:
  "Con a1 a2 a3 = (a1 = a2 \<^bold>\<and> a3 \<or> (\<exists>F G. a1 = \<^bold>\<not> (F \<^bold>\<or> G) \<and> a2 = \<^bold>\<not> F \<and> a3 = \<^bold>\<not> G) \<or> (\<exists>G. a1 = \<^bold>\<not> (a2 \<^bold>\<rightarrow> G) \<and> a3 = \<^bold>\<not> G) \<or> a1 = \<^bold>\<not> (\<^bold>\<not> a2) \<and> a3 = a2)"
  "Dis a1 a2 a3 = (a1 = a2 \<^bold>\<or> a3 \<or> (\<exists>F G. a1 = F \<^bold>\<rightarrow> G \<and> a2 = \<^bold>\<not> F \<and> a3 = G) \<or> (\<exists>F G. a1 = \<^bold>\<not> (F \<^bold>\<and> G) \<and> a2 = \<^bold>\<not> F \<and> a3 = \<^bold>\<not> G) \<or> a1 = \<^bold>\<not> (\<^bold>\<not> a2) \<and> a3 = a2)"
  by(simp_all add: Con.simps Dis.simps)

lemma Hintikka_alt: "Hintikka S = (
  \<bottom> \<notin> S
\<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
\<and> (\<forall>F G H. Con F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<in> S \<and> H \<in> S)
\<and> (\<forall>F G H. Dis F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<in> S \<or> H \<in> S)
)"
  apply(simp add: Hintikka_def con_dis_simps)
  apply(rule iffI)
    (* simp only: \<emptyset> loops. :( *)
   subgoal by blast
  subgoal by safe metis+
done

lemma pcp_alt: "pcp C = (\<forall>S \<in> C.
  \<bottom> \<notin> S
\<and> (\<forall>k. Atom k \<in> S \<longrightarrow> \<^bold>\<not> (Atom k) \<in> S \<longrightarrow> False)
\<and> (\<forall>F G H. Con F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<triangleright> H \<triangleright> S \<in> C)
\<and> (\<forall>F G H. Dis F G H \<longrightarrow> F \<in> S \<longrightarrow> G \<triangleright> S \<in> C \<or> H \<triangleright> S \<in> C)
)"
  apply(simp add: pcp_def con_dis_simps)
  apply(rule iffI; unfold Ball_def; elim all_forward)
  by (auto simp add: insert_absorb split: formula.splits)

definition "subset_closed C \<equiv> (\<forall>S \<in> C. \<forall>s\<subseteq>S. s \<in> C)"
definition "finite_character C \<equiv> (\<forall>S. S \<in> C \<longleftrightarrow> (\<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C))"

lemma ex1: "pcp C \<Longrightarrow> \<exists>C'. C \<subseteq> C' \<and> pcp C' \<and> subset_closed C'"
proof(intro exI[of _ "{s . \<exists>S \<in> C. s \<subseteq> S}"] conjI)
  let ?E = "{s. \<exists>S\<in>C. s \<subseteq> S}"
  show "C \<subseteq> ?E" by blast
  show "subset_closed ?E" unfolding subset_closed_def by blast
  assume C: \<open>pcp C\<close>
  show "pcp ?E" using C unfolding pcp_alt
    by (intro ballI conjI; simp; meson insertI1 rev_subsetD subset_insertI subset_insertI2)
qed

lemma sallI: "(\<And>s. s \<subseteq> S \<Longrightarrow> P s) \<Longrightarrow> \<forall>s \<subseteq> S. P s" by simp

lemma ex2:
  assumes fc: "finite_character C"
  shows "subset_closed C"
  unfolding subset_closed_def
proof (intro ballI sallI)
  fix s S
  assume e: \<open>S \<in> C\<close> and s: \<open>s \<subseteq> S\<close>
  hence *: "t \<subseteq> s \<Longrightarrow> t \<subseteq> S" for t by simp
  from fc have "t \<subseteq> S \<Longrightarrow> finite t \<Longrightarrow> t \<in> C" for t unfolding finite_character_def using e by blast
  hence "t \<subseteq> s \<Longrightarrow> finite t \<Longrightarrow> t \<in> C" for t using * by simp
  with fc show \<open>s \<in> C\<close> unfolding finite_character_def by blast
qed

lemma
  assumes C: "pcp C"
  assumes S: "subset_closed C"
  shows ex3: "\<exists>C'. C \<subseteq> C' \<and> pcp C' \<and> finite_character C'"
proof(intro exI[of _ "C \<union> {S. \<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C}"] conjI)
  let ?E = " {S. \<forall>s \<subseteq> S. finite s \<longrightarrow> s \<in> C}"
  show "C \<subseteq> C \<union> ?E" by blast
  from S show "finite_character (C \<union> ?E)" unfolding finite_character_def subset_closed_def by blast
  note C'' = C[unfolded pcp_alt, THEN bspec]

  (* uniform notation. what did I learn? only slightly more elegant\<dots> *)
  have CON: "G \<triangleright> H \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}" if si: "\<And>s. \<lbrakk>s\<subseteq>S; finite s\<rbrakk> \<Longrightarrow> s \<in> C" and
    un: "Con F G H" and el: " F \<in> S" for F G H S proof -
    have k: "\<forall>s \<subseteq> S. finite s \<longrightarrow> F \<in> s \<longrightarrow> G \<triangleright> H \<triangleright> s \<in> C"
      using si un C'' by simp
    have "G \<triangleright> H \<triangleright> S \<in> ?E"
      unfolding mem_Collect_eq Un_iff proof safe
      fix s
      assume "s \<subseteq> G \<triangleright> H \<triangleright> S" and f: "finite s"
      hence "F \<triangleright> (s - {G,H}) \<subseteq> S" using el by blast
      with k f have "G \<triangleright> H \<triangleright> F \<triangleright> (s - {G,H}) \<in> C" by simp
      hence "F \<triangleright> G \<triangleright> H \<triangleright> s \<in> C" using insert_absorb by fastforce
      thus "s \<in> C" using S unfolding subset_closed_def by fast
    qed
    thus "G \<triangleright> H \<triangleright> S \<in> C \<union> ?E" by simp
  qed
  have DIS: "G \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C} \<or> H \<triangleright> S \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}"
    if si: "\<And>s. s\<subseteq>S \<Longrightarrow> finite s \<Longrightarrow> s \<in> C" and un: "Dis F G H" and el: "F \<in> S"
    for F G H S proof -
    have l: "\<exists>I\<in>{G, H}. I \<triangleright> s1 \<in> C \<and> I \<triangleright> s2 \<in> C"
      if "s1 \<subseteq> S" "finite s1" "F \<in> s1"
         "s2 \<subseteq> S" "finite s2" "F \<in> s2" for s1 s2
    proof -
      let ?s = "s1 \<union> s2"
      have "?s \<subseteq> S" "finite ?s" using that by simp_all
      with si have "?s \<in> C" by simp
      moreover have "F \<in> ?s" using that by simp
      ultimately have "\<exists>I\<in>{G,H}. I \<triangleright> ?s \<in> C"
        using C'' un by simp
      thus "\<exists>I\<in>{G,H}. I \<triangleright> s1 \<in> C \<and> I \<triangleright> s2 \<in> C"
        by (meson S[unfolded subset_closed_def, THEN bspec] insert_mono sup.cobounded2 sup_ge1)
    qed
    have m: "\<lbrakk>s1 \<subseteq> S; finite s1; F \<in> s1; G \<triangleright> s1 \<notin> C; s2 \<subseteq> S; finite s2; F \<in> s2; H \<triangleright> s2 \<notin> C\<rbrakk> \<Longrightarrow> False" for s1 s2
      using l by blast
    have "False" if "s1 \<subseteq> S" "finite s1" "G \<triangleright> s1 \<notin> C" "s2 \<subseteq> S" "finite s2" "H \<triangleright> s2 \<notin> C" for s1 s2
    proof -
      have *: "F \<triangleright> s1 \<subseteq> S" "finite (F \<triangleright> s1)" "F \<in> F \<triangleright> s1" if  "s1 \<subseteq> S" "finite s1" for s1
        using that el by simp_all
      have  "G \<triangleright> F \<triangleright> s1 \<notin> C" "H \<triangleright> F \<triangleright> s2 \<notin> C"
        by (meson S insert_mono subset_closed_def subset_insertI that(3,6))+
      from m[OF *[OF that(1-2)] this(1) *[OF that(4-5)] this(2)]
      show False .
    qed
    hence "G \<triangleright> S \<in> ?E \<or> H \<triangleright> S \<in> ?E"
      unfolding mem_Collect_eq Un_iff
      by (metis (no_types, lifting) finite_Diff insert_Diff si subset_insert_iff)
    thus "G \<triangleright> S \<in> C \<union> ?E \<or> H \<triangleright> S \<in> C \<union> ?E" by blast
  qed

  (* this proof does benefit from uniform notation a bit. Before it was introduced,
     the subclaims CON, DIS had to be stated as *)
  have CON': "\<And>f2 g2 h2 F2 G2 S2. \<lbrakk>\<And>s. \<lbrakk>s \<in> C; h2 F2 G2 \<in> s\<rbrakk> \<Longrightarrow> f2 F2 \<triangleright> s \<in> C \<or> g2 G2 \<triangleright> s \<in> C;
                                   \<forall>s\<subseteq>S2. finite s \<longrightarrow> s \<in> C; h2 F2 G2 \<in> S2; False\<rbrakk>
      \<Longrightarrow> f2 F2 \<triangleright> S2 \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C} \<or> g2 G2 \<triangleright> S2 \<in> C \<union> {S. \<forall>s\<subseteq>S. finite s \<longrightarrow> s \<in> C}"
    by fast
  (* (without the False, obviously). The proof of the subclaim does not change gravely,
      but the f2 g2 h2 have to be instantiated manually upon use (with, e.g., id Not (\<lambda>F G. \<^bold>\<not>(F \<^bold>\<rightarrow> G))),
      and there were multiple working instantiations. Generally not as beautiful. *)

  show "pcp (C \<union> ?E)" unfolding pcp_alt
    apply(intro ballI conjI; elim UnE; (unfold mem_Collect_eq)?)
           subgoal using C'' by blast
          subgoal using C'' by blast
         subgoal using C'' by (simp;fail)
        subgoal by (meson C'' empty_subsetI finite.emptyI finite_insert insert_subset subset_insertI)
       subgoal using C'' by simp
      subgoal using CON by simp
     subgoal using C'' by blast
    subgoal using DIS by simp
  done
qed

primrec pcp_seq where
"pcp_seq C S 0 = S" |
"pcp_seq C S (Suc n) = (
  let Sn = pcp_seq C S n; Sn1 = from_nat n \<triangleright> Sn in
  if Sn1 \<in> C then Sn1 else Sn
)"

lemma pcp_seq_in: "pcp C \<Longrightarrow> S \<in> C \<Longrightarrow> pcp_seq C S n \<in> C"
proof(induction n)
  case (Suc n)
  hence "pcp_seq C S n \<in> C" by simp
  thus ?case by(simp add: Let_def)
qed simp

lemma pcp_seq_mono: "n \<le> m \<Longrightarrow> pcp_seq C S n \<subseteq> pcp_seq C S m"
proof(induction m)
  case (Suc m)
  thus ?case by(cases "n = Suc m"; simp add: Let_def; blast)
qed simp

lemma pcp_seq_UN: "\<Union>{pcp_seq C S n|n. n \<le> m} = pcp_seq C S m"
proof(induction m)
  case (Suc m)
  have "{f n |n. n \<le> Suc m} = f (Suc m) \<triangleright> {f n |n. n \<le> m}" for f using le_Suc_eq by auto
  hence "{pcp_seq C S n |n. n \<le> Suc m} = pcp_seq C S (Suc m) \<triangleright> {pcp_seq C S n |n. n \<le> m}" .
  hence "\<Union>{pcp_seq C S n |n. n \<le> Suc m} = \<Union>{pcp_seq C S n |n. n \<le> m} \<union> pcp_seq C S (Suc m)" by auto
  thus ?case using Suc pcp_seq_mono by blast
qed simp

lemma wont_get_added: "(F :: ('a :: countable) formula) \<notin> pcp_seq C S (Suc (to_nat F)) \<Longrightarrow> F \<notin> pcp_seq C S (Suc (to_nat F) + n)"
text\<open>We don't necessarily have @{term "n = to_nat (from_nat n)"}, so this doesn't hold.\<close>
oops

definition "pcp_lim C S \<equiv> \<Union>{pcp_seq C S n|n. True}"

lemma pcp_seq_sub: "pcp_seq C S n \<subseteq> pcp_lim C S"
  unfolding pcp_lim_def by(induction n; blast)

lemma pcp_lim_inserted_at_ex: "x \<in> pcp_lim C S \<Longrightarrow> \<exists>k. x \<in> pcp_seq C S k"
  unfolding pcp_lim_def by blast

lemma cl_max':
  assumes c: "pcp C"
  assumes sc: "subset_closed C"
  shows "F \<triangleright> pcp_lim C S \<in> C \<Longrightarrow> F \<in> pcp_lim C S"
    "F \<triangleright> G \<triangleright> pcp_lim C S \<in> C \<Longrightarrow> F \<in> pcp_lim C S \<and> G \<in> pcp_lim C S"
using cl_max[OF assms] by blast+

lemma pcp_lim_Hintikka:
  assumes c: "pcp C"
  assumes sc: "subset_closed C"
  assumes fc: "finite_character C"
  assumes el: "S \<in> C"
  shows "Hintikka (pcp_lim C S)"
proof -
  let ?cl = "pcp_lim C S"
  have "?cl \<in> C" using pcp_lim_in[OF c el sc fc] .
  from c[unfolded pcp_alt, THEN bspec, OF this]
  have d: "\<bottom> \<notin> ?cl"
    "Atom k \<in> ?cl \<Longrightarrow> \<^bold>\<not> (Atom k) \<in> ?cl \<Longrightarrow> False"
    "Con F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<triangleright> H \<triangleright> ?cl \<in> C"
    "Dis F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<triangleright> ?cl \<in> C \<or> H \<triangleright> ?cl \<in> C"
  for k F G H by blast+
  have
    "Con F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<in> ?cl \<and> H \<in> ?cl"
    "Dis F G H \<Longrightarrow> F \<in> ?cl \<Longrightarrow> G \<in> ?cl \<or> H \<in> ?cl"
    for F G H
    by(auto dest: d(3-) cl_max'[OF c sc])
  with d(1,2) show ?thesis unfolding Hintikka_alt by fast
qed

theorem pcp_sat: \<comment> \<open>model existence theorem\<close>
  fixes S :: "'a :: countable formula set"
  assumes c: "pcp C"
  assumes el: "S \<in> C"
  shows "sat S"
proof -
  note [[show_types]]
  from c obtain Ce where "C \<subseteq> Ce" "pcp Ce" "subset_closed Ce" "finite_character Ce" using ex1[where 'a='a] ex2[where 'a='a] ex3[where 'a='a]
    by (meson dual_order.trans ex2)
  have "S \<in> Ce" using \<open>C \<subseteq> Ce\<close> el ..
  with pcp_lim_Hintikka \<open>pcp Ce\<close> \<open>subset_closed Ce\<close> \<open>finite_character Ce\<close>
  have  "Hintikka (pcp_lim Ce S)" .
  with Hintikkas_lemma have "sat (pcp_lim Ce S)" .
  moreover have "S \<subseteq> pcp_lim Ce S" using pcp_seq.simps(1) pcp_seq_sub by fast
  ultimately show ?thesis unfolding sat_def by fast
qed
(* This and Hintikka's lemma are the only two where we need semantics.
   Still, I don't think it's meaningful to separate those two into an extra theory. *)

end


theory IHT_Remdups
  imports IHT_Red_Black_Tree IHT_Dynamic_Array_More
    "../Asymptotics/Asymptotics_Recurrences"
    IHT_Reverse
    "HOL-Library.Code_Target_Numeral"
begin

fun remdups2 :: "'a list \<Rightarrow> ('a list * 'a set)" where
  "remdups2 [] = ([],{})"
| "remdups2 (x#xs) = (let (rxs,S) = remdups2 xs in
                    (if x\<in>S then (rxs , S) else (rxs @ [x], S \<union> {x}) ))"

lemma Z: "remdups2 xs = (rev (remdups xs), set xs)"
  by (induct xs, auto)

lemma "remdups2 (rev xs) = (remdups xs, set xs)" oops

fun remdups3 :: "'a list \<Rightarrow> nat \<Rightarrow> ('a list * 'a set)" where
  "remdups3 xs 0 = ([],{})"
| "remdups3 xs (Suc n) = (let (rxs,S) = remdups3 xs n; x = (xs ! (length xs - Suc n)) in
                    (if x \<in> S then (rxs , S) else (rxs @ [x], S \<union> {x}) ))"

lemma kl: "Suc n \<le> length xs \<Longrightarrow>  drop (length xs - Suc n) xs = xs ! (length xs - Suc n) # drop (length xs - n) xs"
proof -
  assume a: "Suc n \<le> length xs" then
  have g: "Suc (length xs - Suc n) = length xs - n" by auto
  from a have "length xs - Suc n < length xs" by auto
  with Cons_nth_drop_Suc[of "length xs - Suc n" xs]
  have "xs ! (length xs - Suc n) # drop (Suc (length xs - Suc n)) xs = drop (length xs - Suc n) xs"
    by blast
  then show ?thesis using g by auto
qed

lemma z: "rev xs @ [x] = rev (x # xs)" by simp
lemma zz: "x = y \<Longrightarrow> rev x = rev y" by simp

lemma remdups3: "n\<le>length xs \<Longrightarrow> remdups3 xs n = remdups2 (drop (length xs - n) xs)"
  apply(induct n)
   apply simp apply simp unfolding Z apply (simp only: Let_def)
  apply(auto)    apply(auto intro!: zz simp add: z simp del: rev.simps)
        apply(simp_all only: kl)  by auto

lemma remdups3_correct[rewrite]: "fst (remdups3 xs (length xs)) = rev (remdups xs)"
  by (simp add: remdups3 Z)

fun remdups'_impl :: "('a::{zero,heap,linorder}) array \<Rightarrow> nat \<Rightarrow> (('a, unit) rbt_node ref option \<times> 'a dynamic_array) Heap"  where
  "remdups'_impl p 0 = do {
            M \<leftarrow> tree_empty;
            A \<leftarrow> dyn_array_new;
          return (M,A) }   "
| "remdups'_impl p (Suc n) = do {
      X \<leftarrow> remdups'_impl p n;
      M \<leftarrow> return (fst X);
      A \<leftarrow> return (snd X);
      l \<leftarrow> Array_Time.len p;
      x \<leftarrow> Array_Time.nth p (l - Suc n);
      b \<leftarrow> rbt_search x M;
      (if b = None then do {
              M' \<leftarrow> rbt_insert x () M  ; A' \<leftarrow> push_array x A; return (M',A') }
               else  return (M,A) )
    }"

fun remdups'_impl_time :: "nat \<Rightarrow> nat" where
  "remdups'_impl_time 0 = 9"
| "remdups'_impl_time (Suc n) = remdups'_impl_time n + rbt_search_time_logN (Suc n)
                                      + rbt_insert_logN (Suc n) + 28"

lemma remdups'_impl_time_bound[asym_bound]: "remdups'_impl_time \<in> \<Theta>(\<lambda>n. n * ln n)"
  apply(rule bigTheta_linear_recurrence_log[where g = "(\<lambda>n. rbt_search_time_logN (1 + n)
                                      + rbt_insert_logN (1 + n) + 28)" and N=11])
       apply simp  apply auto2
  by auto

setup \<open>fold add_rewrite_rule @{thms remdups'_impl_time.simps}\<close>
setup \<open>fold add_rewrite_rule @{thms remdups3.simps}\<close>

definition setmap where [rewrite]: "setmap S = Map (%x. if x\<in>S then Some () else None)"

lemma t: "{x. (if x \<in> set (drop (length xs - n) xs) then Some () else None) = Some ()}
      =  set (drop (length xs - n) xs)" by auto

lemma sizeofmap_ub: "n\<le>length xs \<Longrightarrow> sizeM1 (setmap (snd (remdups3 xs n))) \<le> Suc n"
  unfolding sizeM1_def setmap_def apply (auto simp: remdups3 Z)
  apply(induct n) apply (auto simp: keys_of_def) apply(simp only: kl)
  apply auto subgoal for n apply(cases "xs ! (length xs - Suc n) \<in> (set (drop (length xs - n) xs))")
     apply auto by (simp_all only: t card_insert_le_m1)  done

lemma rbt_search_time_logN_ub[resolve]: "n\<le>length xs \<Longrightarrow> rbt_search_time_logN (sizeM1 (setmap (snd (remdups3 xs n)))) \<le>  rbt_search_time_logN (Suc n) "
  apply(auto simp: sizeofmap_ub  intro!: rbt_search_time_logN_mono) by(auto simp: sizeM1_def)

lemma rbt_insert_logN_ub[resolve]: "n\<le>length xs \<Longrightarrow> rbt_insert_logN (sizeM1 (setmap (snd (remdups3 xs n)))) \<le>  rbt_insert_logN (Suc n) "
  apply(auto simp: sizeofmap_ub  intro!: rbt_insert_logN_mono) by (auto simp: sizeM1_def)

setup \<open>del_prfstep_thm @{thm rbt_map_def}\<close>
setup \<open>del_prfstep_thm @{thm rbt_in_traverse_fst}\<close>
setup \<open>del_prfstep_thm @{thm rbt_map_assn_def}\<close>

lemma remdups'_impl_rule[hoare_triple]:
  "n\<le>length xs \<Longrightarrow> <p \<mapsto>\<^sub>a xs * $(remdups'_impl_time n)>
    remdups'_impl p n
   <\<lambda>(M,A). p \<mapsto>\<^sub>a xs * dyn_array (fst (remdups3 xs n)) A * rbt_map_assn (setmap (snd (remdups3 xs n))) M >\<^sub>t"
@proof @fun_induct "remdups3 xs n" @with
  @subgoal "(xs = xs, n = 0)"
    @have "setmap (snd (remdups3 xs 0)) = empty_map"
  @endgoal
  @subgoal "(xs = xs, n = Suc n)"
    @have "rbt_search_time_logN (Suc n) \<ge>\<^sub>t rbt_search_time_logN (sizeM1 (setmap (snd (remdups3 xs n))))"
    @case "setmap (snd (remdups3 xs n)) \<langle>xs ! (length xs - Suc n) \<rangle> = None" @with
      @have "rbt_insert_logN (Suc n) \<ge>\<^sub>t rbt_insert_logN (sizeM1 (setmap (snd (remdups3 xs n))))"
      @have "setmap (snd (remdups3 xs n)) { xs ! (length xs - Suc n) \<rightarrow> () } = setmap (snd (remdups3 xs (Suc n)))"
    @end
  @endgoal
  @end
@qed

definition remdups_impl :: "('a::{zero,heap,linorder}) array \<Rightarrow> 'a array Heap"  where [rewrite]:
    "remdups_impl p = do {
        len \<leftarrow> Array_Time.len p;
        (_,A) \<leftarrow> remdups'_impl p len;
        r \<leftarrow> destroy A;
        rev_impl r
    }"

lemma rev_impl_time_absch[resolve]: "rev_time (length xs) \<ge> rev_time (length (remdups xs))"
  by(rule rev_impl_time_mono, simp)

definition remdups_impl_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "remdups_impl_time n = 4 + remdups'_impl_time n + rev_time n"

lemma remdups_impl_time_bound[asym_bound]:
    "remdups_impl_time \<in> \<Theta>(\<lambda>n. n * ln n)"
  unfolding remdups_impl_time_def by auto2

lemma rev_rev[rewrite]: "rev (rev xs) = xs" by simp

lemma remdups_impl_rule[hoare_triple]: "<p \<mapsto>\<^sub>a xs * $(remdups_impl_time (length xs))>
    remdups_impl p
   <\<lambda>r. p \<mapsto>\<^sub>a xs * r \<mapsto>\<^sub>a remdups xs>\<^sub>t"
@proof
  @have "rev_time (length xs) \<ge>\<^sub>t rev_time (length (remdups xs))"
@qed

declare rbt_ins.simps[code]
declare IHT_Red_Black_Tree.rbt_search.simps[code]

definition "remdups_int_impl \<equiv> remdups_impl :: int array \<Rightarrow> _"

export_code integer_of_int int_of_integer remdups_int_impl
  in "SML_imp"  module_name REMDUPS (* does not work properly! *)

end


(* Title: RTS/Common/CollectionSemantics.thy *)
(* Author: Susannah Mansky, UIUC 2020 *)

section "Collection Semantics"

theory CollectionSemantics
imports Semantics
begin

text "General model for small step semantics instrumented
 with an information collection mechanism:"
locale CollectionSemantics = Semantics +
 constrains
  small :: "'prog \<Rightarrow> 'state \<Rightarrow> 'state set" and
  endset :: "'state set"
 fixes
  collect :: "'prog \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> 'coll" and
  combine :: "'coll \<Rightarrow> 'coll \<Rightarrow> 'coll" and
  collect_id :: "'coll"
 assumes
  combine_assoc: "combine (combine c1 c2) c3 = combine c1 (combine c2 c3)" and
  collect_idl[simp]: "combine collect_id c = c" and
  collect_idr[simp]: "combine c collect_id = c"

context CollectionSemantics begin

subsection "Small-Step Collection Semantics"

definition csmall :: "'prog \<Rightarrow> 'state \<Rightarrow> ('state \<times> 'coll) set" where
"csmall P \<sigma> \<equiv> { (\<sigma>', coll). \<sigma>' \<in> small P \<sigma> \<and> collect P \<sigma> \<sigma>' = coll }"

lemma small_det_csmall_det:
assumes "\<forall>\<sigma>. small P \<sigma> = {} \<or> (\<exists>\<sigma>'. small P \<sigma> = {\<sigma>'})"
shows "\<forall>\<sigma>. csmall P \<sigma> = {} \<or> (\<exists>o'. csmall P \<sigma> = {o'})"
using assms by(fastforce simp: csmall_def)

subsection "Extending @{term csmall} to multiple steps"

primrec csmall_nstep :: "'prog \<Rightarrow> 'state \<Rightarrow> nat \<Rightarrow> ('state \<times> 'coll) set" where
csmall_nstep_base:
 "csmall_nstep P \<sigma> 0 = {(\<sigma>, collect_id)}" |
csmall_nstep_Rec:
 "csmall_nstep P \<sigma> (Suc n) =
  { (\<sigma>2, coll). \<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall_nstep P \<sigma> n
                      \<and> (\<sigma>2, coll2) \<in> csmall P \<sigma>1 \<and> combine coll1 coll2 = coll }"

lemma small_nstep_csmall_nstep_equiv:
 "small_nstep P \<sigma> n
       = { \<sigma>'. \<exists>coll. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n }"
proof (induct n) qed(simp_all add: csmall_def)

lemma csmall_nstep_exists:
 "\<sigma>' \<in> big P \<sigma> \<Longrightarrow> \<exists>n coll. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset"
proof(drule bigD) qed(clarsimp simp: small_nstep_csmall_nstep_equiv)

lemma csmall_det_csmall_nstep_det:
assumes "\<forall>\<sigma>. csmall P \<sigma> = {} \<or> (\<exists>o'. csmall P \<sigma> = {o'})"
shows "\<forall>\<sigma>. csmall_nstep P \<sigma> n = {} \<or> (\<exists>o'. csmall_nstep P \<sigma> n = {o'})"
using assms
proof(induct n)
  case (Suc n) then show ?case by fastforce
qed(simp)

lemma csmall_nstep_Rec2:
 "csmall_nstep P \<sigma> (Suc n) =
  { (\<sigma>2, coll). \<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall P \<sigma>
                      \<and> (\<sigma>2, coll2) \<in> csmall_nstep P \<sigma>1 n \<and> combine coll1 coll2 = coll }"
proof(induct n arbitrary: \<sigma>)
  case (Suc n)
  have right: "\<And>\<sigma>' coll'. (\<sigma>', coll') \<in> csmall_nstep P \<sigma> (Suc(Suc n))
    \<Longrightarrow> \<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall P \<sigma>
                      \<and> (\<sigma>', coll2) \<in> csmall_nstep P \<sigma>1 (Suc n) \<and> combine coll1 coll2 = coll'"
  proof -
    fix \<sigma>' coll'
    assume "(\<sigma>', coll') \<in> csmall_nstep P \<sigma> (Suc(Suc n))"
    then obtain \<sigma>1 coll1 coll2 where Sucnstep: "(\<sigma>1, coll1) \<in> csmall_nstep P \<sigma> (Suc n)"
                        "(\<sigma>', coll2) \<in> csmall P \<sigma>1" "combine coll1 coll2 = coll'" by fastforce
    obtain \<sigma>12 coll12 coll22 where nstep: "(\<sigma>12, coll12) \<in> csmall P \<sigma>
                        \<and> (\<sigma>1, coll22) \<in> csmall_nstep P \<sigma>12 n \<and> combine coll12 coll22 = coll1"
      using Suc Sucnstep(1) by fastforce
    then show "\<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall P \<sigma>
                      \<and> (\<sigma>', coll2) \<in> csmall_nstep P \<sigma>1 (Suc n) \<and> combine coll1 coll2 = coll'"
     using combine_assoc[of coll12 coll22 coll2] Sucnstep by fastforce
  qed
  have left: "\<And>\<sigma>' coll'. \<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall P \<sigma>
                      \<and> (\<sigma>', coll2) \<in> csmall_nstep P \<sigma>1 (Suc n) \<and> combine coll1 coll2 = coll'
    \<Longrightarrow> (\<sigma>', coll') \<in> csmall_nstep P \<sigma> (Suc(Suc n))"
  proof -
    fix \<sigma>' coll'
    assume "\<exists>\<sigma>1 coll1 coll2. (\<sigma>1, coll1) \<in> csmall P \<sigma>
                      \<and> (\<sigma>', coll2) \<in> csmall_nstep P \<sigma>1 (Suc n) \<and> combine coll1 coll2 = coll'"
    then obtain \<sigma>1 coll1 coll2 where Sucnstep: "(\<sigma>1, coll1) \<in> csmall P \<sigma>"
                      "(\<sigma>', coll2) \<in> csmall_nstep P \<sigma>1 (Suc n)" "combine coll1 coll2 = coll'"
      by fastforce
    obtain \<sigma>12 coll12 coll22 where nstep: "(\<sigma>12, coll12) \<in> csmall_nstep P \<sigma>1 n
                        \<and> (\<sigma>', coll22) \<in> csmall P \<sigma>12 \<and> combine coll12 coll22 = coll2"
      using Sucnstep(2) by auto
    then show "(\<sigma>', coll') \<in> csmall_nstep P \<sigma> (Suc(Suc n))"
      using combine_assoc[of coll1 coll12 coll22] Suc Sucnstep by fastforce
  qed
  show ?case using right left by fast
qed(simp)

lemma csmall_nstep_SucD:
assumes "(\<sigma>',coll') \<in> csmall_nstep P \<sigma> (Suc n)"
shows "\<exists>\<sigma>1 coll1. (\<sigma>1, coll1) \<in> csmall P \<sigma>
   \<and> (\<exists>coll. coll' = combine coll1 coll \<and> (\<sigma>',coll) \<in> csmall_nstep P \<sigma>1 n)"
  using csmall_nstep_Rec2 CollectionSemantics_axioms case_prodD assms by fastforce

lemma csmall_nstep_Suc_nend: "o' \<in> csmall_nstep P \<sigma> (Suc n1) \<Longrightarrow> \<sigma> \<notin> endset"
  using endset_final csmall_nstep_SucD CollectionSemantics.csmall_def CollectionSemantics_axioms
  by fastforce

lemma small_to_csmall_nstep_pres:
assumes Qpres: "\<And>P \<sigma> \<sigma>'. Q P \<sigma> \<Longrightarrow> \<sigma>' \<in> small P \<sigma> \<Longrightarrow> Q P \<sigma>'"
shows "Q P \<sigma> \<Longrightarrow> (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<Longrightarrow> Q P \<sigma>'"
proof(induct n arbitrary: \<sigma> \<sigma>' coll)
  case (Suc n)
  then obtain \<sigma>1 coll1 coll2 where nstep: "(\<sigma>1, coll1) \<in> csmall_nstep P \<sigma> n
                      \<and> (\<sigma>', coll2) \<in> csmall P \<sigma>1 \<and> combine coll1 coll2 = coll" by clarsimp
  then show ?case using Suc Qpres[where P=P and \<sigma>=\<sigma>1 and \<sigma>'=\<sigma>'] by(auto simp: csmall_def)
qed(simp)

lemma csmall_to_csmall_nstep_prop:
assumes cond: "\<And>P \<sigma> \<sigma>' coll. (\<sigma>', coll) \<in> csmall P \<sigma> \<Longrightarrow> R P coll \<Longrightarrow> Q P \<sigma> \<Longrightarrow> R' P \<sigma> \<sigma>' coll"
  and Rcomb: "\<And>P coll1 coll2. R P (combine coll1 coll2) = (R P coll1 \<and> R P coll2)"
  and Qpres: "\<And>P \<sigma> \<sigma>'. Q P \<sigma> \<Longrightarrow> \<sigma>' \<in> small P \<sigma> \<Longrightarrow> Q P \<sigma>'"
  and Rtrans': "\<And>P \<sigma> \<sigma>1 \<sigma>' coll1 coll2.
                        R' P \<sigma> \<sigma>1 coll1 \<and> R' P \<sigma>1 \<sigma>' coll2 \<Longrightarrow> R' P \<sigma> \<sigma>' (combine coll1 coll2)"
  and base: "\<And>\<sigma>. R' P \<sigma> \<sigma> collect_id"
shows "(\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<Longrightarrow> R P coll \<Longrightarrow> Q P \<sigma> \<Longrightarrow> R' P \<sigma> \<sigma>' coll"
proof(induct n arbitrary: \<sigma> \<sigma>' coll)
  case (Suc n)
  then obtain \<sigma>1 coll1 coll2 where nstep: "(\<sigma>1, coll1) \<in> csmall_nstep P \<sigma> n
                      \<and> (\<sigma>', coll2) \<in> csmall P \<sigma>1 \<and> combine coll1 coll2 = coll" by clarsimp
  then have "Q P \<sigma>1" using small_to_csmall_nstep_pres[where Q=Q] Qpres Suc by blast
  then show ?case using nstep assms Suc by auto blast
qed(simp add: base)

lemma csmall_to_csmall_nstep_prop2:
assumes cond: "\<And>P P' \<sigma> \<sigma>' coll. (\<sigma>', coll) \<in> csmall P \<sigma>
             \<Longrightarrow> R P P' coll \<Longrightarrow> Q \<sigma> \<Longrightarrow> (\<sigma>', coll) \<in> csmall P' \<sigma>"
  and Rcomb: "\<And>P P' coll1 coll2. R P P' (combine coll1 coll2) = (R P P' coll1 \<and> R P P' coll2)"
  and Qpres: "\<And>P \<sigma> \<sigma>'. Q \<sigma> \<Longrightarrow> \<sigma>' \<in> small P \<sigma> \<Longrightarrow> Q \<sigma>'"
shows "(\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<Longrightarrow> R P P' coll \<Longrightarrow> Q \<sigma> \<Longrightarrow> (\<sigma>', coll) \<in> csmall_nstep P' \<sigma> n"
proof(induct n arbitrary: \<sigma> \<sigma>' coll)
  case (Suc n)
  then obtain \<sigma>1 coll1 coll2 where nstep: "(\<sigma>1, coll1) \<in> csmall_nstep P \<sigma> n
                      \<and> (\<sigma>', coll2) \<in> csmall P \<sigma>1 \<and> combine coll1 coll2 = coll" by clarsimp
  then have "Q \<sigma>1" using small_to_csmall_nstep_pres[where Q="\<lambda>P. Q"] Qpres Suc by blast
  then show ?case using nstep assms Suc by auto blast
qed(simp)

subsection "Extending @{term csmall} to a big-step semantics"

definition cbig :: "'prog \<Rightarrow> 'state \<Rightarrow> ('state \<times> 'coll) set" where
"cbig P \<sigma> \<equiv>
  { (\<sigma>', coll). \<exists>n. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset }"

lemma cbigD:
 "\<lbrakk> (\<sigma>',coll') \<in> cbig P \<sigma> \<rbrakk> \<Longrightarrow> \<exists>n. (\<sigma>',coll') \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset"
  by(simp add: cbig_def)

lemma cbigD':
 "\<lbrakk> o' \<in> cbig P \<sigma> \<rbrakk> \<Longrightarrow> \<exists>n. o' \<in> csmall_nstep P \<sigma> n \<and> fst o' \<in> endset"
  by(cases o', simp add: cbig_def)

lemma cbig_def2:
 "(\<sigma>', coll) \<in> cbig P \<sigma> \<longleftrightarrow> (\<exists>n. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset)"
proof(rule iffI)
  assume "(\<sigma>', coll) \<in> cbig P \<sigma>"
  then show "\<exists>n. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset" using bigD cbig_def by auto
next
  assume "\<exists>n. (\<sigma>', coll) \<in> csmall_nstep P \<sigma> n \<and> \<sigma>' \<in> endset"
  then show "(\<sigma>', coll) \<in> cbig P \<sigma>" using big_def cbig_def small_nstep_csmall_nstep_equiv by auto
qed

lemma cbig_big_equiv:
 "(\<exists>coll. (\<sigma>', coll) \<in> cbig P \<sigma>) \<longleftrightarrow> \<sigma>' \<in> big P \<sigma>"
proof(rule iffI)
  assume "\<exists>coll. (\<sigma>', coll) \<in> cbig P \<sigma>"
  then show "\<sigma>' \<in> big P \<sigma>" by (auto simp: big_def cbig_def small_nstep_csmall_nstep_equiv)
next
  assume "\<sigma>' \<in> big P \<sigma>"
  then show "\<exists>coll. (\<sigma>', coll) \<in> cbig P \<sigma>" by (fastforce simp: cbig_def dest: csmall_nstep_exists)
qed

lemma cbig_big_implies:
 "(\<sigma>', coll) \<in> cbig P \<sigma> \<Longrightarrow> \<sigma>' \<in> big P \<sigma>"
using cbig_big_equiv by blast

lemma csmall_to_cbig_prop:
assumes "\<And>P \<sigma> \<sigma>' coll. (\<sigma>', coll) \<in> csmall P \<sigma> \<Longrightarrow> R P coll \<Longrightarrow> Q P \<sigma> \<Longrightarrow> R' P \<sigma> \<sigma>' coll"
  and "\<And>P coll1 coll2. R P (combine coll1 coll2) = (R P coll1 \<and> R P coll2)"
  and "\<And>P \<sigma> \<sigma>'. Q P \<sigma> \<Longrightarrow> \<sigma>' \<in> small P \<sigma> \<Longrightarrow> Q P \<sigma>'"
  and "\<And>P \<sigma> \<sigma>1 \<sigma>' coll1 coll2.
                        R' P \<sigma> \<sigma>1 coll1 \<and> R' P \<sigma>1 \<sigma>' coll2 \<Longrightarrow> R' P \<sigma> \<sigma>' (combine coll1 coll2)"
  and "\<And>\<sigma>. R' P \<sigma> \<sigma> collect_id"
shows "(\<sigma>', coll) \<in> cbig P \<sigma> \<Longrightarrow> R P coll \<Longrightarrow> Q P \<sigma> \<Longrightarrow> R' P \<sigma> \<sigma>' coll"
using assms csmall_to_csmall_nstep_prop[where R=R and Q=Q and R'=R' and \<sigma>=\<sigma>]
  by(auto simp: cbig_def2)

lemma csmall_to_cbig_prop2:
assumes "\<And>P P' \<sigma> \<sigma>' coll. (\<sigma>', coll) \<in> csmall P \<sigma> \<Longrightarrow> R P P' coll \<Longrightarrow> Q \<sigma> \<Longrightarrow> (\<sigma>', coll) \<in> csmall P' \<sigma>"
  and "\<And>P P' coll1 coll2. R P P' (combine coll1 coll2) = (R P P' coll1 \<and> R P P' coll2)"
  and Qpres: "\<And>P \<sigma> \<sigma>'. Q \<sigma> \<Longrightarrow> \<sigma>' \<in> small P \<sigma> \<Longrightarrow> Q \<sigma>'"
shows "(\<sigma>', coll) \<in> cbig P \<sigma> \<Longrightarrow> R P P' coll \<Longrightarrow> Q \<sigma> \<Longrightarrow> (\<sigma>', coll) \<in> cbig P' \<sigma>"
using assms csmall_to_csmall_nstep_prop2[where R=R and Q=Q] by(auto simp: cbig_def2) blast

lemma cbig_stepD:
assumes cbig: "(\<sigma>',coll') \<in> cbig P \<sigma>" and nend: "\<sigma> \<notin> endset"
shows "\<exists>\<sigma>1 coll1. (\<sigma>1, coll1) \<in> csmall P \<sigma>
   \<and> (\<exists>coll. coll' = combine coll1 coll \<and> (\<sigma>',coll) \<in> cbig P \<sigma>1)"
proof -
  obtain n where n: "(\<sigma>', coll') \<in> csmall_nstep P \<sigma> n" "\<sigma>' \<in> endset"
    using cbig_def2 cbig by auto
  then show ?thesis using csmall_nstep_SucD nend cbig_def2 by(cases n, simp) blast
qed

(****)

lemma csmall_nstep_det_last_eq:
assumes det: "\<forall>\<sigma>. small P \<sigma> = {} \<or> (\<exists>\<sigma>'. small P \<sigma> = {\<sigma>'})"
shows "\<lbrakk> (\<sigma>',coll') \<in> cbig P \<sigma>; (\<sigma>',coll') \<in> csmall_nstep P \<sigma> n; (\<sigma>',coll'') \<in> csmall_nstep P \<sigma> n' \<rbrakk>
 \<Longrightarrow> n = n'"
proof(induct n arbitrary: n' \<sigma> \<sigma>' coll' coll'')
  case 0
  have "\<sigma>' = \<sigma>" using "0.prems"(2) csmall_nstep_base by blast
  then have endset: "\<sigma> \<in> endset" using "0.prems"(1) cbigD by blast
  show ?case
  proof(cases n')
    case Suc then show ?thesis using "0.prems"(3) csmall_nstep_Suc_nend endset by blast
  qed(simp)
next
  case (Suc n1)
  then have endset: "\<sigma>' \<in> endset" using Suc.prems(1) cbigD by blast
  have nend: "\<sigma> \<notin> endset" using csmall_nstep_Suc_nend[OF Suc.prems(2)] by simp
  then have neq: "\<sigma>' \<noteq> \<sigma>" using endset by auto
  obtain \<sigma>1 coll coll1 where \<sigma>1: "(\<sigma>1,coll1) \<in> csmall P \<sigma>" "coll' = combine coll1 coll"
     "(\<sigma>',coll) \<in> csmall_nstep P \<sigma>1 n1"
    using csmall_nstep_SucD[OF Suc.prems(2)] by clarsimp
  then have cbig: "(\<sigma>',coll) \<in> cbig P \<sigma>1" using endset by(auto simp: cbig_def)
  show ?case
  proof(cases n')
    case 0 then show ?thesis using neq Suc.prems(3) using csmall_nstep_base by simp
  next
    case Suc': (Suc n1')
    then obtain \<sigma>1' coll2 coll1' where \<sigma>1': "(\<sigma>1',coll1') \<in> csmall P \<sigma>" "coll'' = combine coll1' coll2"
      "(\<sigma>',coll2) \<in> csmall_nstep P \<sigma>1' n1'"
      using csmall_nstep_SucD[where \<sigma>=\<sigma> and \<sigma>'=\<sigma>' and coll'=coll'' and n=n1'] Suc.prems(3) by blast
    then have "\<sigma>1=\<sigma>1'" using \<sigma>1 det csmall_def by auto
    then show ?thesis using Suc.hyps(1)[OF cbig \<sigma>1(3)] \<sigma>1'(3) Suc' by blast
  qed
qed

end \<comment> \<open> CollectionSemantics \<close>

end