theory Insider
imports AT
begin
datatype action = get | move | eval |put
typedecl actor
type_synonym identity = string
consts Actor :: "string => actor"
type_synonym policy = "((actor => bool) * action set)"

definition ID :: "[actor, string] \<Rightarrow> bool"
where "ID a s \<equiv> (a = Actor s)"

datatype location = Location nat
  datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                         "actor \<Rightarrow> (string set * string set)"  "location \<Rightarrow> string set"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph ,location] \<Rightarrow> policy set"

primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string set)"
where  "lgra(Lgraph g a c l) = l"

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string set"
where "lspace (Infrastructure g d) = lgra g"

definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"

definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s \<in> (lgra G l)"

datatype psy_states = happy | depressed | disgruntled | angry | stressed
datatype motivations = financial | political | revenge | curious | competitive_advantage | power | peer_recognition

datatype actor_state = Actor_state "psy_states" "motivations set"
primrec motivation :: "actor_state \<Rightarrow> motivations set"
where "motivation  (Actor_state p m) =  m"
primrec psy_state :: "actor_state \<Rightarrow> psy_states"
where "psy_state  (Actor_state p m) = p"

definition tipping_point :: "actor_state \<Rightarrow> bool" where
  "tipping_point a \<equiv> ((motivation a \<noteq> {}) \<and> (happy \<noteq> psy_state a))"

(* idea:: predicate to flag that an actor is isolated *)
consts Isolation :: "[actor_state, (identity * identity) set ] \<Rightarrow> bool"

(* use above to redefine infrastructure -- adapt policies in nodes
   so that layed off workers cannot access any more *)
definition lay_off :: "[infrastructure,actor set] \<Rightarrow> infrastructure"
where "lay_off G A \<equiv> G"

(* idea: social graph is derived from activities in infrastructure.
   Since actors are nodes in the infrastructure graph, we need to
   have a second graph only on actors reflecting their interaction. *)
consts social_graph :: "(identity * identity) set"
(* This social graph is a parameter to the theory. It depends on
   actual measured activities. We will use it to derive meta-theorems. *)

definition UasI ::  "[identity, identity] \<Rightarrow> bool "
where "UasI a b \<equiv> (Actor a = Actor b) \<and> (\<forall> x y. x \<noteq> a \<and> y \<noteq> a \<and> Actor x = Actor y \<longrightarrow> x = y)"

definition UasI' ::  "[actor => bool, identity, identity] \<Rightarrow> bool "
where "UasI' P a b \<equiv> P (Actor b) \<longrightarrow> P (Actor a)"

(* derive theorems about UasI being a equivalence relation *)

consts astate :: "identity \<Rightarrow> actor_state"

definition Insider :: "[identity, identity set] \<Rightarrow> bool"
where "Insider a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI a b))"

definition Insider' :: "[actor \<Rightarrow> bool, identity, identity set] \<Rightarrow> bool"
where "Insider' P a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI' P a b \<and> inj_on Actor C))"

definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

(* behaviour is the good behaviour, i.e. everything allowed by policy *)
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

(* Most general: misbehaviour is the complement of behaviour *)
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "misbehaviour I \<equiv> -(behaviour I)"

(* state transition on infrastructures *)
declare [[show_types]]
(*
primrec del :: "['a, 'a list] \<Rightarrow> 'a list"
where
del_nil: "del a [] = []" |
del_cons: "del a (x#ls) = (if x = a then ls else x # (del a ls))"
*)

primrec jonce :: "['a, 'a list] \<Rightarrow> bool"
where
jonce_nil: "jonce a [] = False" |
jonce_cons: "jonce a (x#ls) = (if x = a then (a \<notin> (set ls)) else jonce a ls)"

primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"

definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)"

inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; a' @\<^bsub>G\<^esub> l; has G (Actor a, z);
        enables I l (Actor a) get;
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)
                           ((cgra G)(Actor a' :=
                                (insert z (fst(cgra G (Actor a'))), snd(cgra G (Actor a')))))
                           (lgra G))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; enables I l (Actor a) put;
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                          ((lgra G)(l := {z})))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

(* show that this infrastructure is a state as given in MC.thy *)
instantiation "infrastructure" :: state
begin

definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

(* del related results not needed since we use sets here for credentials etc
lemma del_del[rule_format]: "n \<in> set (del a S) \<longrightarrow> n \<in> set S"
  apply (induct_tac S)
  by auto
*)
(* Not true in the current formulation of del since copies are not
   deleted. But changing that causes extra complxity also elsewhere
   (see jonce)
lemma del_del_elim[rule_format]: "n \<in> set (S) \<longrightarrow> n \<notin> set (del n S)" *)

(*
lemma del_dec[rule_format]: "a \<in> set S \<longrightarrow> length (del a S) < length S"
  apply (induct_tac S)
    by auto

lemma del_sort[rule_format]: "\<forall> n. (Suc n ::nat) \<le> length (l) \<longrightarrow> n \<le> length (del a (l))"
  apply (induct_tac l)
   apply simp
  apply clarify
  apply (case_tac n)
   apply simp
    by simp

lemma del_jonce: "jonce a l \<longrightarrow> a \<notin> set (del a l)"
  apply (induct_tac l)
  by auto

lemma del_nodup[rule_format]: "nodup a l \<longrightarrow> a \<notin> set(del a l)"
  apply (induct_tac l)
  by auto

lemma nodup_up[rule_format]: "a \<in> set (del a l) \<longrightarrow> a \<in> set l"
  apply (induct_tac l)
  by auto

    lemma del_up [rule_format]: "a \<in> set (del aa l) \<longrightarrow> a \<in> set l"
   apply (induct_tac l)
  by auto

lemma nodup_notin[rule_format]:   "a \<notin> set list \<longrightarrow> nodup a list"
  apply (induct_tac list)
  by auto

    lemma nodup_down[rule_format]: "nodup a l \<longrightarrow> nodup a (del a l)"
      apply (induct_tac l)
       apply simp+
      apply (clarify)
    by (erule nodup_notin)

lemma del_notin_down[rule_format]: "a \<notin> set list \<longrightarrow> a \<notin> set (del aa list) "
  apply (induct_tac list)
  by auto

lemma del_not_a[rule_format]: " x \<noteq> a \<longrightarrow> x \<in> set l \<longrightarrow> x \<in> set (del a l)"
  apply (induct_tac l)
    by auto

lemma nodup_down_notin[rule_format]: "nodup a l \<longrightarrow> nodup a (del aa l)"
  apply (induct_tac l)
   apply simp+
    apply (rule conjI)
  apply (clarify)
   apply (erule nodup_notin)
  apply (rule impI)+
 by (erule del_notin_down)
*)

lemma move_graph_eq: "move_graph_a a l l g = g"
proof (simp add: move_graph_a_def, case_tac g, force)
qed

end


(*  Title:      ZF/Inductive.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Inductive definitions use least fixedpoints with standard products and sums
Coinductive definitions use greatest fixedpoints with Quine products and sums

Sums are used only for mutual recursion;
Products are used only to derive "streamlined" induction rules for relations
*)

section\<open>Inductive and Coinductive Definitions\<close>

theory Inductive
imports Fixedpt QPair Nat
keywords
  "inductive" "coinductive" "inductive_cases" "rep_datatype" "primrec" :: thy_decl and
  "domains" "intros" "monos" "con_defs" "type_intros" "type_elims"
    "elimination" "induction" "case_eqns" "recursor_eqns" :: quasi_command
begin

lemma def_swap_iff: "a \<equiv> b \<Longrightarrow> a = c \<longleftrightarrow> c = b"
  by blast

lemma def_trans: "f \<equiv> g \<Longrightarrow> g(a) = b \<Longrightarrow> f(a) = b"
  by simp

lemma refl_thin: "\<And>P. a = a \<Longrightarrow> P \<Longrightarrow> P" .

ML_file \<open>ind_syntax.ML\<close>
ML_file \<open>Tools/ind_cases.ML\<close>
ML_file \<open>Tools/cartprod.ML\<close>
ML_file \<open>Tools/inductive_package.ML\<close>
ML_file \<open>Tools/induct_tacs.ML\<close>
ML_file \<open>Tools/primrec_package.ML\<close>

ML \<open>
structure Lfp =
  struct
  val oper      = \<^Const>\<open>lfp\<close>
  val bnd_mono  = \<^Const>\<open>bnd_mono\<close>
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_lfp_subset}
  val Tarski    = @{thm def_lfp_unfold}
  val induct    = @{thm def_induct}
  end;

structure Standard_Prod =
  struct
  val sigma     = \<^Const>\<open>Sigma\<close>
  val pair      = \<^Const>\<open>Pair\<close>
  val split_name = \<^const_name>\<open>split\<close>
  val pair_iff  = @{thm Pair_iff}
  val split_eq  = @{thm split}
  val fsplitI   = @{thm splitI}
  val fsplitD   = @{thm splitD}
  val fsplitE   = @{thm splitE}
  end;

structure Standard_CP = CartProd_Fun (Standard_Prod);

structure Standard_Sum =
  struct
  val sum       = \<^Const>\<open>sum\<close>
  val inl       = \<^Const>\<open>Inl\<close>
  val inr       = \<^Const>\<open>Inr\<close>
  val elim      = \<^Const>\<open>case\<close>
  val case_inl  = @{thm case_Inl}
  val case_inr  = @{thm case_Inr}
  val inl_iff   = @{thm Inl_iff}
  val inr_iff   = @{thm Inr_iff}
  val distinct  = @{thm Inl_Inr_iff}
  val distinct' = @{thm Inr_Inl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Standard_Prod.pair_iff]
  end;

structure Ind_Package =
    Add_inductive_def_Fun
      (structure Fp=Lfp and Pr=Standard_Prod and CP=Standard_CP
       and Su=Standard_Sum val coind = false);

structure Gfp =
  struct
  val oper      = \<^Const>\<open>gfp\<close>
  val bnd_mono  = \<^Const>\<open>bnd_mono\<close>
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_gfp_subset}
  val Tarski    = @{thm def_gfp_unfold}
  val induct    = @{thm def_Collect_coinduct}
  end;

structure Quine_Prod =
  struct
  val sigma     = \<^Const>\<open>QSigma\<close>
  val pair      = \<^Const>\<open>QPair\<close>
  val split_name = \<^const_name>\<open>qsplit\<close>
  val pair_iff  = @{thm QPair_iff}
  val split_eq  = @{thm qsplit}
  val fsplitI   = @{thm qsplitI}
  val fsplitD   = @{thm qsplitD}
  val fsplitE   = @{thm qsplitE}
  end;

structure Quine_CP = CartProd_Fun (Quine_Prod);

structure Quine_Sum =
  struct
  val sum       = \<^Const>\<open>qsum\<close>
  val inl       = \<^Const>\<open>QInl\<close>
  val inr       = \<^Const>\<open>QInr\<close>
  val elim      = \<^Const>\<open>qcase\<close>
  val case_inl  = @{thm qcase_QInl}
  val case_inr  = @{thm qcase_QInr}
  val inl_iff   = @{thm QInl_iff}
  val inr_iff   = @{thm QInr_iff}
  val distinct  = @{thm QInl_QInr_iff}
  val distinct' = @{thm QInr_QInl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Quine_Prod.pair_iff]
  end;

structure CoInd_Package =
  Add_inductive_def_Fun(structure Fp=Gfp and Pr=Quine_Prod and CP=Quine_CP
    and Su=Quine_Sum val coind = true);

\<close>

end


section \<open>Finding a Path between Nodes\<close>
theory DFS_Find_Path
imports
  "../DFS_Framework"
  CAVA_Automata.Digraph_Impl
  "../Misc/Impl_Rev_Array_Stack"
begin
text \<open>
  We instantiate the DFS framework to find a path to some reachable node
  that satisfies a given predicate. We present four variants of the algorithm:
  Finding any path, and finding path of at least length one, combined with
  searching the whole graph, and searching the graph restricted to a given set
  of nodes. The restricted variants are efficiently implemented by
  pre-initializing the visited set (cf. @{theory DFS_Framework.Restr_Impl}).

  The restricted variants can be used for incremental search, ignoring already
  searched nodes in further searches. This is required, e.g., for the inner
  search of nested DFS (Buchi automaton emptiness check).
\<close>

subsection \<open>Including empty Path\<close>
record 'v fp0_state = "'v state" +
  ppath :: "('v list \<times> 'v) option"

type_synonym 'v fp0_param = "('v, ('v,unit) fp0_state_ext) parameterization"

abbreviation "no_path \<equiv> \<lparr> ppath = None \<rparr>"
abbreviation "a_path p v \<equiv> \<lparr> ppath = Some (p,v) \<rparr>"

definition fp0_params :: "('v \<Rightarrow> bool) \<Rightarrow> 'v fp0_param"
  where "fp0_params P \<equiv> \<lparr>
  on_init = RETURN no_path,
  on_new_root = \<lambda>v0 s. if P v0 then RETURN (a_path [] v0) else RETURN no_path,
  on_discover = \<lambda>u v s. if P v
                   then \<comment> \<open>\<open>v\<close> is already on the stack, so we need to pop it again\<close>
                      RETURN (a_path (rev (tl (stack s))) v)
                   else RETURN no_path,
  on_finish = \<lambda>u s. RETURN (state.more s),
  on_back_edge = \<lambda>u v s. RETURN (state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_simps[simp]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_def]

interpretation fp0: param_DFS_defs where param = "fp0_params P"
  for G P .

locale fp0 = param_DFS G "fp0_params P"
  for G and P :: "'v \<Rightarrow> bool"
begin

  lemma [simp]:
    "ppath (empty_state \<lparr>ppath = e\<rparr>) = e"
    by (simp add: empty_state_def)

  lemma [simp]:
    "ppath (s\<lparr>state.more := state.more s'\<rparr>) = ppath s'"
    by (cases s, cases s') auto

  sublocale DFS where param = "fp0_params P"
    by unfold_locales simp_all

end

lemma fp0I: assumes "fb_graph G" shows "fp0 G"
proof - interpret fb_graph G by fact show ?thesis by unfold_locales qed

locale fp0_invar = fp0 +
  DFS_invar where param = "fp0_params P"

lemma fp0_invar_eq[simp]:
  "DFS_invar G (fp0_params P) = fp0_invar G P"
proof (intro ext iffI)
  fix s
  assume "DFS_invar G (fp0_params P) s"
  interpret DFS_invar G "fp0_params P" s by fact
  show "fp0_invar G P s" by unfold_locales
next
  fix s
  assume "fp0_invar G P s"
  interpret fp0_invar G P s by fact
  show "DFS_invar G (fp0_params P) s" by unfold_locales
qed

context fp0 begin

  lemma i_no_path_no_P_discovered:
    "is_invar (\<lambda>s. ppath s = None \<longrightarrow> dom (discovered s) \<inter> Collect P = {})"
  by (rule establish_invarI) simp_all

  lemma i_path_to_P:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow> P v)"
  by (rule establish_invarI) auto

  lemma i_path_invar:
    "is_invar (\<lambda>s. ppath s = Some (vs,v) \<longrightarrow>
                   (vs \<noteq> [] \<longrightarrow> hd vs \<in> V0 \<and> path E (hd vs) vs v)
                 \<and> (vs = [] \<longrightarrow> v \<in> V0 \<and> path E v vs v)
                 \<and> (distinct (vs@[v]))
                 )"
  proof (induct rule: establish_invarI)
    case (discover s s' u v) then interpret fp0_invar where s=s
      by simp

    from discover have ne: "stack s \<noteq> []" by simp
    from discover have vnis: "v\<notin>set (stack s)" using stack_discovered by auto

    from pendingD discover have "v \<in> succ (hd (stack s))" by simp
    with hd_succ_stack_is_path[OF ne] have "\<exists>v0\<in>V0. path E v0 (rev (stack s)) v" .
    moreover from last_stack_in_V0 ne have "last (stack s) \<in> V0" by simp
    ultimately have "path E (hd (rev (stack s)))  (rev (stack s)) v" "hd (rev (stack s)) \<in> V0"
      using hd_rev path_hd[where p="rev (stack s)"] ne
      by auto
    with ne discover vnis show ?case by (auto simp: stack_distinct)
  qed auto
end

context fp0_invar
begin
  lemmas no_path_no_P_discovered
    = i_no_path_no_P_discovered[THEN make_invar_thm, rule_format]

  lemmas path_to_P
    = i_path_to_P[THEN make_invar_thm, rule_format]

  lemmas path_invar
    = i_path_invar[THEN make_invar_thm, rule_format]

  lemma path_invar_nonempty:
    assumes "ppath s = Some (vs,v)"
    and "vs \<noteq> []"
    shows "hd vs \<in> V0" "path E (hd vs) vs v"
    using assms path_invar
    by auto

  lemma path_invar_empty:
    assumes "ppath s = Some (vs,v)"
    and "vs = []"
    shows "v \<in> V0" "path E v vs v"
    using assms path_invar
    by auto

  lemma fp0_correct:
    assumes "\<not>cond s"
    shows "case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v]))"
  proof (cases "ppath s")
    case None with assms nc_discovered_eq_reachable no_path_no_P_discovered have
      "reachable \<inter> Collect P = {}" by auto
    thus ?thesis by (auto simp add: None)
  next
    case (Some vvs) then obtain v vs where [simp]: "vvs = (vs,v)"
      by (cases vvs) auto

    from Some path_invar[of vs v] path_to_P[of _ v] show ?thesis
      by auto
  qed

end

context fp0 begin
  lemma fp0_correct: "it_dfs \<le> SPEC (\<lambda>s. case ppath s of
      None \<Rightarrow> \<not>(\<exists>v0\<in>V0. \<exists>v. (v0,v) \<in> E\<^sup>* \<and> P v)
    | Some (p,v) \<Rightarrow> (\<exists>v0\<in>V0. path E v0 p v \<and> P v \<and> distinct (p@[v])))"
    apply (rule weaken_SPEC[OF it_dfs_correct])
    apply clarsimp
    apply (simp add: fp0_invar.fp0_correct)
    done
end

subsubsection \<open>Basic Interface\<close>
text \<open>Use this interface, rather than the internal stuff above! \<close>
(* Making it a well-defined interface. This interface should be used, not
  the internal stuff. If more information about the result is needed, this
  interface should be extended! *)

type_synonym 'v fp_result = "('v list \<times> 'v) option"
definition "find_path0_pred G P \<equiv> \<lambda>r. case r of
    None \<Rightarrow> (g_E G)\<^sup>* `` g_V0 G \<inter> Collect P = {}
  | Some (vs,v) \<Rightarrow> P v \<and> distinct (vs@[v]) \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"

definition find_path0_spec
  :: "('v, _) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  \<comment> \<open>Searches a path from the root nodes to some target node that satisfies a
      given predicate. If such a path is found, the path and the target node
      are returned\<close>
where
  "find_path0_spec G P \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path0_pred G P)
  }"

definition find_path0
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  where "find_path0 G P \<equiv> do {
  ASSERT (fp0 G);
  s \<leftarrow> fp0.it_dfs TYPE('more) G P;
  RETURN (ppath s)
}"

lemma find_path0_correct:
  shows "find_path0 G P \<le> find_path0_spec G P"
  unfolding find_path0_def find_path0_spec_def find_path0_pred_def
  apply (refine_vcg le_ASSERTI order_trans[OF fp0.fp0_correct])
  apply (erule fp0I)
  apply (auto split: option.split) []
  done

lemmas find_path0_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_spec_def]
  ASSERT_leof_defI[OF find_path0_spec_def]

subsection \<open>Restricting the Graph\<close>
text \<open> Extended interface, propagating set of already searched nodes (restriction) \<close>
(* Invariant for restriction: The restriction is closed under E
  and contains no P-nodes *)
definition restr_invar
  \<comment> \<open>Invariant for a node restriction, i.e., a transition closed set of nodes
    known to not contain a target node that satisfies a predicate.\<close>
  where
  "restr_invar E R P \<equiv> E `` R \<subseteq> R \<and> R \<inter> Collect P = {}"

lemma restr_invar_triv[simp, intro!]: "restr_invar E {} P"
  unfolding restr_invar_def by simp

lemma restr_invar_imp_not_reachable: "restr_invar E R P \<Longrightarrow> E\<^sup>*``R \<inter> Collect P = {}"
  unfolding restr_invar_def by (simp add: Image_closed_trancl)

type_synonym 'v fpr_result = "'v set + ('v list \<times> 'v)"
definition "find_path0_restr_pred G P R \<equiv> \<lambda>r.
    case r of
      Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>* `` g_V0 G \<and> restr_invar (g_E G) R' P
    | Inr (vs,v) \<Rightarrow> P v \<and> (\<exists> v0 \<in> g_V0 G - R. path (rel_restrict (g_E G) R) v0 vs v)"

definition find_path0_restr_spec
  \<comment> \<open>Find a path to a target node that satisfies a predicate, not considering
      nodes from the given node restriction. If no path is found, an extended
      restriction is returned, that contains the start nodes\<close>
  where "find_path0_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path0_restr_pred G P R)}"

lemmas find_path0_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path0_restr_spec_def]
  ASSERT_leof_defI[OF find_path0_restr_spec_def]

definition find_path0_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path0_restr G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0.it_dfs TYPE('more) (graph_restrict G R) P;
  case ppath s of
    None \<Rightarrow> do {
      ASSERT (dom (discovered s) = dom (finished s));
      RETURN (Inl (R \<union> dom (finished s)))
    }
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_correct:
  shows "find_path0_restr G P R \<le> find_path0_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path0_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb_graph "graph_restrict G R" by (rule a.fb_graph_restrict)

  assume I: "restr_invar (g_E G) R P"

  define reachable where "reachable = graph_defs.reachable (graph_restrict G R)"

  interpret fp0 "graph_restrict G R" by unfold_locales

  show ?thesis unfolding find_path0_restr_def find_path0_restr_spec_def
    apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF it_dfs_correct])
    apply unfold_locales
    apply (clarsimp_all)
  proof -
    fix s
    assume "fp0_invar (graph_restrict G R) P s"
      and NC[simp]: "\<not>fp0.cond TYPE('b) (graph_restrict G R) P s"
    then interpret fp0_invar "graph_restrict G R" P s by simp

    {
      assume [simp]: "ppath s = None"

      from nc_discovered_eq_finished
      show "dom (discovered s) = dom (finished s)" by simp

      from nc_finished_eq_reachable
      have DFR[simp]: "dom (finished s) = reachable"
        by (simp add: reachable_def)

      from I have "g_E G `` R \<subseteq> R" unfolding restr_invar_def by auto

      have "reachable \<subseteq> (g_E G)\<^sup>* `` g_V0 G"
        unfolding reachable_def
        by (rule Image_mono, rule rtrancl_mono) (auto simp: rel_restrict_def)

      hence "R \<union> dom (finished s) = R \<union> (g_E G)\<^sup>* `` g_V0 G"
        apply -
        apply (rule equalityI)
        apply auto []
        unfolding DFR reachable_def
        apply (auto elim: E_closed_restr_reach_cases[OF _ \<open>g_E G `` R \<subseteq> R\<close>]) []
        done
      moreover from nc_fin_closed I
      have "g_E G `` (R \<union> dom (finished s)) \<subseteq> R \<union> dom (finished s)"
        unfolding restr_invar_def by (simp add: rel_restrict_def) blast
      moreover from no_path_no_P_discovered nc_discovered_eq_finished I
      have "(R \<union> dom (finished s)) \<inter> Collect P = {}"
        unfolding restr_invar_def by auto
      ultimately
      show "find_path0_restr_pred G P R (Inl (R \<union> dom (finished s)))"
        unfolding restr_invar_def find_path0_restr_pred_def by auto
    }

    {
      fix v vs
      assume [simp]: "ppath s = Some (vs,v)"
      from fp0_correct
      show "find_path0_restr_pred G P R (Inr (vs, v))"
        unfolding find_path0_restr_pred_def by auto
    }
  qed
qed

subsection \<open>Path of Minimal Length One, with Restriction\<close>
definition "find_path1_restr_pred G P R \<equiv> \<lambda>r.
      case r of
        Inl R' \<Rightarrow> R' = R \<union> (g_E G)\<^sup>+ `` g_V0 G \<and> restr_invar (g_E G) R' P
      | Inr (vs,v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G \<inter> UNIV \<times> -R) v0 vs v)"

definition find_path1_restr_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies P.
    Takes an initial node restriction, and returns an extended node restriction.\<close>
  where "find_path1_restr_spec G P R \<equiv> do {
    ASSERT (fb_graph G \<and> restr_invar (g_E G) R P);
    SPEC (find_path1_restr_pred G P R)}"

lemmas find_path1_restr_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_restr_spec_def]
  ASSERT_leof_defI[OF find_path1_restr_spec_def]

definition find_path1_restr
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v set \<Rightarrow> 'v fpr_result nres"
  where "find_path1_restr G P R \<equiv>
  FOREACHc (g_V0 G) is_Inl (\<lambda>v0 s. do {
    ASSERT (is_Inl s); \<comment> \<open>TODO: Add FOREACH-condition as precondition in autoref!\<close>
    let R = projl s;
    f0 \<leftarrow> find_path0_restr_spec (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>) P R;
    case f0 of
      Inl _ \<Rightarrow> RETURN f0
    | Inr (vs,v) \<Rightarrow> RETURN (Inr (v0#vs,v))
  }) (Inl R)"

definition "find_path1_tailrec_invar G P R0 it s \<equiv>
  case s of
    Inl R \<Rightarrow> R = R0 \<union> (g_E G)\<^sup>+ `` (g_V0 G - it) \<and> restr_invar (g_E G) R P
  | Inr (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G - it. path (g_E G \<inter> UNIV \<times> -R0) v0 vs v)"

lemma find_path1_restr_correct:
  shows "find_path1_restr G P R \<le> find_path1_restr_spec G P R"
proof (rule le_ASSERT_defI1[OF find_path1_restr_spec_def], clarify)
  assume "fb_graph G"
  interpret a: fb_graph G by fact
  interpret fb0: fb_graph "G \<lparr> g_E := g_E G \<inter> UNIV \<times> -R \<rparr>"
    by (rule a.fb_graph_subset, auto)

  assume I: "restr_invar (g_E G) R P"

  have aux2: "\<And>v0. v0 \<in> g_V0 G \<Longrightarrow> fb_graph (G \<lparr> g_V0 := g_E G `` {v0} \<rparr>)"
    by (rule a.fb_graph_subset, auto)

  {
    fix v0 it s
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and RI: "restr_invar (g_E G) (projl s \<union> (g_E G)\<^sup>+ `` {v0}) P"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0})
            (Inl (projl s \<union> (g_E G)\<^sup>+ `` {v0}))"
      using RI
      by (auto simp: find_path1_tailrec_invar_def it_step_insert_iff[OF IT])
  } note aux4 = this

  {
    fix v0 u it s v p
    assume IT: "it \<subseteq> g_V0 G" "v0 \<in> it"
    and "is_Inl s"
    and FPI: "find_path1_tailrec_invar G P R it s"
    and PV: "P v"
    and PATH: "path (rel_restrict (g_E G) (projl s)) u p v" "(v0,u)\<in>(g_E G)"
    and PR: "u \<notin> projl s"

    then obtain R' where [simp]: "s = Inl R'" by (cases s) auto

    from FPI have [simp]: "R' = R \<union> (g_E G)\<^sup>+ `` (g_V0 G - it)"
      unfolding find_path1_tailrec_invar_def by simp

    have "find_path1_tailrec_invar G P R (it - {v0}) (Inr (v0 # p, v))"
      apply (simp add: find_path1_tailrec_invar_def PV)
      apply (rule bexI[where x=v0])
        using PR PATH(2) path_mono[OF rel_restrict_mono2[of R] PATH(1)]
        apply (auto simp: path1_restr_conv) []

        using IT apply blast
      done
  } note aux5 = this

  show ?thesis
    unfolding find_path1_restr_def find_path1_restr_spec_def find_path1_restr_pred_def
    apply (refine_rcg le_ASSERTI
      refine_vcg FOREACHc_rule[where I="find_path1_tailrec_invar G P R"]
      (*order_trans[OF find_path0_restr_correct]*)
      )
    apply simp
    using I apply (auto simp add: find_path1_tailrec_invar_def restr_invar_def) []

    apply (blast intro: aux2)
    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) []
    apply (auto
      simp: find_path0_restr_pred_def aux4 aux5
      simp: trancl_Image_unfold_left[symmetric]
      split: sum.splits) []

    apply (auto simp add: find_path1_tailrec_invar_def split: sum.splits) [2]
    done
qed

definition "find_path1_pred G P \<equiv> \<lambda>r.
      case r of
        None \<Rightarrow> (g_E G)\<^sup>+ `` g_V0 G \<inter> Collect P = {}
      | Some (vs, v) \<Rightarrow> P v \<and> vs \<noteq> [] \<and> (\<exists> v0 \<in> g_V0 G. path (g_E G) v0 vs v)"
definition find_path1_spec
  \<comment> \<open>Find a path of length at least one to a target node that satisfies
      a given predicate.\<close>
  where "find_path1_spec G P \<equiv> do {
    ASSERT (fb_graph G);
    SPEC (find_path1_pred G P)}"

lemmas find_path1_spec_rule[refine_vcg] =
  ASSERT_le_defI[OF find_path1_spec_def]
  ASSERT_leof_defI[OF find_path1_spec_def]

subsection \<open>Path of Minimal Length One, without Restriction\<close>
definition find_path1
  :: "('v, 'more) graph_rec_scheme \<Rightarrow> ('v \<Rightarrow> bool) \<Rightarrow> 'v fp_result nres"
  where "find_path1 G P \<equiv> do {
  r \<leftarrow> find_path1_restr_spec G P {};
  case r of
    Inl _ \<Rightarrow> RETURN None
  | Inr vsv \<Rightarrow> RETURN (Some vsv)
}"

lemma find_path1_correct:
  shows "find_path1 G P \<le> find_path1_spec G P"
  unfolding find_path1_def find_path1_spec_def find_path1_pred_def
  apply (refine_rcg refine_vcg le_ASSERTI order_trans[OF find_path1_restr_correct])
  apply simp
  apply (fastforce
    simp: find_path1_restr_spec_def find_path1_restr_pred_def
    split: sum.splits
    dest!: restr_invar_imp_not_reachable tranclD)
  done

subsection \<open>Implementation\<close>

(* Implementation with stack *)
record 'v fp0_state_impl = "'v simple_state" +
  ppath :: "('v list \<times> 'v) option"

definition "fp0_erel \<equiv> {
  (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p\<rparr>) | p. True }"

abbreviation "fp0_rel R \<equiv> \<langle>fp0_erel\<rangle>restr_simple_state_rel R"

abbreviation "no_path_impl \<equiv> \<lparr> fp0_state_impl.ppath = None \<rparr>"
abbreviation "a_path_impl p v \<equiv> \<lparr> fp0_state_impl.ppath = Some (p,v) \<rparr>"

lemma fp0_rel_ppath_cong[simp]:
  "(s,s')\<in>fp0_rel R \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding restr_simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0_ss_rel_ppath_cong[simp]:
  "(s,s')\<in>\<langle>fp0_erel\<rangle>simple_state_rel \<Longrightarrow> fp0_state_impl.ppath s = fp0_state.ppath s'"
  unfolding simple_state_rel_def fp0_erel_def
  by (cases s, cases s', auto)

lemma fp0i_cong[cong]: "simple_state.more s = simple_state.more s'
  \<Longrightarrow> fp0_state_impl.ppath s = fp0_state_impl.ppath s'"
  by (cases s, cases s', auto)

lemma fp0_erelI: "p=p'
  \<Longrightarrow> (\<lparr> fp0_state_impl.ppath = p \<rparr>, \<lparr> fp0_state.ppath = p'\<rparr>)\<in>fp0_erel"
  unfolding fp0_erel_def by auto

definition fp0_params_impl
  :: "_ \<Rightarrow> ('v,'v fp0_state_impl,('v,unit)fp0_state_impl_ext) gen_parameterization"
where "fp0_params_impl P \<equiv> \<lparr>
  on_init = RETURN no_path_impl,
  on_new_root = \<lambda>v0 s.
    if P v0 then RETURN (a_path_impl [] v0) else RETURN no_path_impl,
  on_discover = \<lambda>u v s.
    if P v then RETURN (a_path_impl (map fst (rev (tl (CAST (ss_stack s))))) v)
    else RETURN no_path_impl,
  on_finish = \<lambda>u s. RETURN (simple_state.more s),
  on_back_edge = \<lambda>u v s. RETURN (simple_state.more s),
  on_cross_edge = \<lambda>u v s. RETURN (simple_state.more s),
  is_break = \<lambda>s. ppath s \<noteq> None \<rparr>"

lemmas fp0_params_impl_simp[simp, DFS_code_unfold]
  = gen_parameterization.simps[mk_record_simp, OF fp0_params_impl_def]

interpretation fp0_impl:
  restricted_impl_defs "fp0_params_impl P" "fp0_params P" G R
  for G P R .

locale fp0_restr = fb_graph
begin
  sublocale fp0?: fp0 "graph_restrict G R"
    apply (rule fp0I)
    apply (rule fb_graph_restrict)
    done

  sublocale impl: restricted_impl G "fp0_params P" "fp0_params_impl P"
    fp0_erel R
    apply unfold_locales
      apply parametricity

      apply (simp add: fp0_erel_def)
      apply (auto) [1]

      apply (auto
        simp: rev_map[symmetric] map_tl comp_def
        simp: fp0_erel_def simple_state_rel_def) [7]

      apply (auto simp: restr_rel_def) [3]
      apply (clarsimp simp: restr_rel_def)
      apply (rule IdD) apply (subst list_rel_id_simp[symmetric])
      apply parametricity
    done
end

definition "find_path0_restr_impl G P R \<equiv> do {
  ASSERT (fb_graph G);
  ASSERT (fp0 (graph_restrict G R));
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G R P;
  case ppath s of
    None \<Rightarrow> RETURN (Inl (visited s))
  | Some (vs,v) \<Rightarrow> RETURN (Inr (vs,v))
}"

lemma find_path0_restr_impl[refine]:
  shows "find_path0_restr_impl G P R
     \<le> \<Down>(\<langle>Id,Id\<times>\<^sub>rId\<rangle>sum_rel)
   (find_path0_restr G P R)"
proof (rule refine_ASSERT_defI2[OF find_path0_restr_def])
  assume "fb_graph G"
  then interpret fb_graph G .
  interpret fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_restr_impl_def find_path0_restr_def
   apply (refine_rcg impl.tailrec_refine)
   apply refine_dref_type
   apply (auto simp: restr_simple_state_rel_def)
   done
qed

definition "find_path0_impl G P \<equiv> do {
  ASSERT (fp0 G);
  s \<leftarrow> fp0_impl.tailrec_impl TYPE('a) G {} P;
  RETURN (ppath s)
}"

lemma find_path0_impl[refine]: "find_path0_impl G P
  \<le> \<Down> (\<langle>Id\<times>\<^sub>rId\<rangle>option_rel) (find_path0 G P)"
proof (rule refine_ASSERT_defI1[OF find_path0_def])
  assume "fp0 G"
  then interpret fp0 G .
  interpret r: fp0_restr G by unfold_locales

  show ?thesis
   unfolding find_path0_impl_def find_path0_def
   apply (refine_rcg r.impl.tailrec_refine[where R="{}", simplified])
   apply (auto)
   done
qed

subsection \<open>Synthesis of Executable Code\<close>
(* Autoref *)

record ('v,'si,'nsi)fp0_state_impl' = "('si,'nsi)simple_state_nos_impl" +
  ppath_impl :: "('v list \<times> 'v) option"

definition [to_relAPP]: "fp0_state_erel erel \<equiv> {
  (\<lparr>ppath_impl = pi, \<dots> =  mi\<rparr>,\<lparr>ppath = p, \<dots> = m\<rparr>) | pi mi p m.
    (pi,p)\<in>\<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<and> (mi,m)\<in>erel}"

consts
  i_fp0_state_ext :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of fp0_state_erel i_fp0_state_ext]

term fp0_state_impl_ext
lemma [autoref_rules]:
  fixes ns_rel vis_rel erel
  defines "R \<equiv> \<langle>ns_rel,vis_rel,\<langle>erel\<rangle>fp0_state_erel\<rangle>ssnos_impl_rel"
  shows
    "(fp0_state_impl'_ext, fp0_state_impl_ext)
      \<in> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel \<rightarrow> erel \<rightarrow> \<langle>erel\<rangle>fp0_state_erel"
    "(ppath_impl, fp0_state_impl.ppath) \<in> R \<rightarrow> \<langle>\<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>option_rel"
  unfolding fp0_state_erel_def ssnos_impl_rel_def R_def
  by auto

schematic_goal find_path0_code:
  fixes G :: "('v :: hashable, _) graph_rec_scheme"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi, P) \<in> Id \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>Id::('v\<times>'v) set\<rangle>dflt_ahs_rel"]
  shows "(nres_of (?c::?'c dres), find_path0_impl G P) \<in> ?R"
  unfolding find_path0_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_code uses find_path0_code
export_code find_path0_code checking SML

lemma find_path0_autoref_aux:
  assumes Vid: "Rv = (Id :: 'a :: hashable rel)"
  shows "(\<lambda>G P. nres_of (find_path0_code G P), find_path0_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel)
      \<rightarrow> \<langle>\<langle>\<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>option_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_code.refine[param_fo, THEN nres_relD]],
    assumption+
    )
  using find_path0_impl find_path0_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_autoref[autoref_rules] = find_path0_autoref_aux[OF PREFER_id_D]

schematic_goal find_path0_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of (?c::?'c dres),
    find_path0_restr_impl
      G
      P
      (R:::\<^sub>r\<langle>Id\<rangle>vis_rel)) \<in> ?R"
  unfolding find_path0_restr_impl_def[abs_def] DFS_code_unfold ssnos_unfolds
  unfolding if_cancel not_not comp_def nres_monad_laws
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path0_restr_code uses find_path0_restr_code
export_code find_path0_restr_code checking SML

lemma find_path0_restr_autoref_aux:
  assumes 1: "(op_vis_insert, insert)\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> \<langle>Rv\<rangle>vis_rel"
  assumes 2: "(op_vis_memb, (\<in>))\<in>Rv \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid: "Rv = Id"
  shows "(\<lambda> G P R. nres_of (find_path0_restr_code op_vis_insert op_vis_memb G P R),
    find_path0_restr_spec)
    \<in> \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> (Rv \<rightarrow> bool_rel) \<rightarrow> \<langle>Rv\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>Rv\<rangle>vis_rel, \<langle>Rv\<rangle>list_rel \<times>\<^sub>r Rv\<rangle>sum_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  unfolding Vid
  apply (rule
    order_trans[OF find_path0_restr_code.refine[OF 1[unfolded Vid] 2[unfolded Vid], param_fo, THEN nres_relD]]
    )
  apply assumption+
  using find_path0_restr_impl find_path0_restr_correct
  apply (simp add: pw_le_iff refine_pw_simps)
  apply blast
  done
lemmas find_path0_restr_autoref[autoref_rules] = find_path0_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_restr_code:
  fixes vis_rel :: "('v\<times>'v) set \<Rightarrow> ('visi\<times>'v set) set"
  notes [autoref_rel_intf] = REL_INTFI[of vis_rel "i_set" for I]
  assumes [autoref_rules]: "(op_vis_insert, insert)\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> \<langle>Id\<rangle>vis_rel"
  assumes [autoref_rules]: "(op_vis_memb, (\<in>))\<in>Id \<rightarrow> \<langle>Id\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes [autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, Id\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>Id \<rightarrow> bool_rel"
    "(Ri,R)\<in>\<langle>Id\<rangle>vis_rel"
  shows "(nres_of ?c,find_path1_restr G P R)
  \<in> \<langle>\<langle>\<langle>Id\<rangle>vis_rel, \<langle>Id\<rangle>list_rel \<times>\<^sub>r Id\<rangle>sum_rel\<rangle>nres_rel"
  unfolding find_path1_restr_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done

concrete_definition find_path1_restr_code uses find_path1_restr_code
export_code find_path1_restr_code checking SML

lemma find_path1_restr_autoref_aux:
  assumes G: "(op_vis_insert, insert)\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> \<langle>V\<rangle>vis_rel"
             "(op_vis_memb, (\<in>))\<in>V \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow> bool_rel"
  assumes Vid[simp]: "V=Id"
  shows "(\<lambda> G P R. nres_of (find_path1_restr_code op_vis_insert op_vis_memb G P R),find_path1_restr_spec)
  \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>V\<rangle>vis_rel \<rightarrow>
    \<langle>\<langle>\<langle>V\<rangle>vis_rel, \<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>sum_rel\<rangle>nres_rel"

proof -
  note find_path1_restr_code.refine[OF G[simplified], param_fo, THEN nres_relD]
  also note find_path1_restr_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_restr_autoref[autoref_rules] = find_path1_restr_autoref_aux[OF GEN_OP_D GEN_OP_D PREFER_id_D]

schematic_goal find_path1_code:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  assumes [unfolded Vid,autoref_rules]:
    "(Gi, G) \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext"
    "(Pi,P)\<in>V \<rightarrow> bool_rel"
  notes [autoref_tyrel] = TYRELI[where R="\<langle>(Id::('a\<times>'a::hashable)set)\<rangle>dflt_ahs_rel"]
  shows "(nres_of ?c,find_path1 G P)
  \<in> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
  unfolding find_path1_def[abs_def] Vid
  using [[autoref_trace_failed_id]]
  apply (autoref_monadic (trace))
  done
concrete_definition find_path1_code uses find_path1_code

export_code find_path1_code checking SML

lemma find_path1_code_autoref_aux:
  assumes Vid: "V = (Id :: 'a :: hashable rel)"
  shows "(\<lambda> G P. nres_of (find_path1_code G P), find_path1_spec)
    \<in> \<langle>Rm, V\<rangle>g_impl_rel_ext \<rightarrow> (V \<rightarrow> bool_rel) \<rightarrow> \<langle>\<langle>\<langle>V\<rangle>list_rel \<times>\<^sub>r V\<rangle>option_rel\<rangle>nres_rel"
proof -
  note find_path1_code.refine[OF Vid, param_fo, THEN nres_relD, simplified]
  also note find_path1_correct
  finally show ?thesis by (force intro!: nres_relI)
qed

lemmas find_path1_autoref[autoref_rules] = find_path1_code_autoref_aux[OF PREFER_id_D]

subsection \<open>Conclusion\<close>
text \<open>
  We have synthesized an efficient implementation for an algorithm to find a path
  to a reachable node that satisfies a predicate. The algorithm comes in four variants,
  with and without empty path, and with and without node restriction.

  We have set up the Autoref tool, to insert this algorithms for the following
  specifications:
  \<^item> @{term "find_path0_spec G P"} --- find path to node that satisfies @{term P}.
  \<^item> @{term "find_path1_spec G P"} --- find non-empty path to node that satisfies @{term P}.
  \<^item> @{term "find_path0_restr_spec G P R"} --- find path, with nodes from @{term R} already searched.
  \<^item> @{term "find_path1_restr_spec"} --- find non-empty path, with nodes from @{term R} already searched.

\<close>
thm find_path0_autoref
thm find_path1_autoref
thm find_path0_restr_autoref
thm find_path1_restr_autoref

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Additions to RB-Trees} *}
theory RBT_add
imports
  "~~/src/HOL/Library/RBT_Impl"
  "../Iterator/Iterator"
begin
text_raw {*\label{thy:RBT_add}*}

lemma tlt_trans: "\<lbrakk>l |\<guillemotleft> u; u\<le>v\<rbrakk> \<Longrightarrow> l |\<guillemotleft> v"
  by (induct l) auto

lemma trt_trans: "\<lbrakk> u\<le>v; v\<guillemotleft>|r \<rbrakk> \<Longrightarrow> u\<guillemotleft>|r"
  by (induct r) auto

lemmas tlt_trans' = tlt_trans[OF _ less_imp_le]
lemmas trt_trans' = trt_trans[OF less_imp_le]

primrec rm_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_iterateoi (RBT_Impl.Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_iterateoi l c f \<sigma> in
        if (c \<sigma>') then
          rm_iterateoi r c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_iterateoi_alt_def :
  "rm_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_iterateoi l)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_iterateoi r))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_iterateoi.simps[simp del]

primrec rm_reverse_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_reverse_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_reverse_iterateoi (Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_reverse_iterateoi r c f \<sigma> in
        if (c \<sigma>') then
          rm_reverse_iterateoi l c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_reverse_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_reverse_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_reverse_iterateoi_alt_def :
  "rm_reverse_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_reverse_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_reverse_iterateoi r)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_reverse_iterateoi l))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_reverse_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_reverse_iterateoi.simps[simp del]

(*
lemma finite_dom_lookup [simp, intro!]: "finite (dom (RBT.lookup t))"
by(simp add: RBT.lookup_def)

instantiation rbt :: ("{equal, linorder}", equal) equal begin

definition "equal_class.equal (r :: ('a, 'b) rbt) r' == RBT.impl_of r = RBT.impl_of r'"

instance
proof
qed (simp add: equal_rbt_def RBT.impl_of_inject)

end
*)

lemma (in linorder) map_to_set_lookup_entries:
   "rbt_sorted t \<Longrightarrow> map_to_set (rbt_lookup t) = set (RBT_Impl.entries t)"
  using map_of_entries[symmetric,of t]
  by (simp add: distinct_entries map_to_set_map_of)

lemma (in linorder) rm_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv>
  RBT_add.rm_iterateoi::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_iterateoi_alt_def
      map_iterator_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_linord_sng_correct[of k v]

  have kv_r_it : "set_iterator_map_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it r))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r))"
  proof (rule map_iterator_linord_union_correct [OF kv_it r_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup r)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule PairE)

    from pre is_sort_t show "fst kv < fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_greater_prop)
      done
  qed

  have l_kv_r_it : "set_iterator_map_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup l)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)))"
    unfolding it_def rm_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_linord_union_correct [OF l_it kv_r_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup l)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule PairE)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule PairE)

    from pre is_sort_t show "fst kv1 < fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (lifting) map_of_entries neqE option.simps(3)
        ord.rbt_lookup_rbt_greater ord.rbt_lookup_rbt_less rbt_greater_trans
        rbt_less_trans weak_map_of_SomeI)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup l)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (simp add: set_eq_iff map_to_set_lookup_entries)

  from l_kv_r_it[unfolded map_eq]
  show ?case .
qed

lemma (in linorder) rm_reverse_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv> RBT_add.rm_reverse_iterateoi
    ::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_rev_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_reverse_iterateoi_alt_def
      map_iterator_rev_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_rev_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_rev_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_rev_linord_sng_correct[of k v]

  have kv_l_it : "set_iterator_map_rev_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it l))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l))"
  proof (rule map_iterator_rev_linord_union_correct [OF kv_it l_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup l)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule PairE)

    from pre is_sort_t show "fst kv > fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_less_prop)
   done
  qed

  have r_kv_l_it : "set_iterator_map_rev_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup r)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)))"
    unfolding it_def rm_reverse_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_rev_linord_union_correct [OF r_it kv_l_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup r)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule PairE)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule PairE)

    from pre is_sort_t show "fst kv1 > fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (mono_tags) entry_in_tree_keys neq_iff option.simps(3)
        ord.rbt_greater_prop ord.rbt_lookup_rbt_less rbt_less_trans
        rbt_lookup_in_tree)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup r)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (auto simp add: set_eq_iff map_to_set_lookup_entries)

  from r_kv_l_it[unfolded map_eq]
  show ?case .
qed

lemma pi_rm[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_iterateoi t) (RBT_add.rm_iterateoi t)"
  by (induct t) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)

lemma pi_rm_rev[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_reverse_iterateoi t) (RBT_add.rm_reverse_iterateoi t)"
  by (induct t) (simp_all add: rm_reverse_iterateoi_alt_def
    icf_proper_iteratorI)

primrec bheight_aux :: "('a,'b) RBT_Impl.rbt \<Rightarrow> nat \<Rightarrow> nat"
where
  "\<And>acc. bheight_aux RBT_Impl.Empty acc = acc"
| "\<And>acc. bheight_aux (RBT_Impl.Branch c lt k v rt) acc =
     bheight_aux lt (case c of RBT_Impl.B \<Rightarrow> Suc acc | RBT_Impl.R \<Rightarrow> acc)"

lemma bheight_aux_eq: "bheight_aux t a = bheight t + a"
  by (induct t arbitrary: a) (auto split: RBT_Impl.color.split)

definition [code_unfold]: "rbt_bheight t \<equiv> bheight_aux t 0"
lemma "rbt_bheight t = bheight t"
  unfolding rbt_bheight_def by (simp add: bheight_aux_eq)

(*definition "black_height t \<equiv> rbt_bheight (RBT.impl_of t)"*)

end


(* Title: Stream_Fusion_LList
  Author: Andreas Lochbihler, ETH Zurich *)

header {* Stream fusion for coinductive lists *}

theory Stream_Fusion_LList imports
  Stream_Fusion_List
  "../Coinductive/Coinductive_List"
begin

text {*
  There are two choices of how many @{const Skip}s may occur consecutively.
  \begin{itemize}
  \item A generator for @{typ "'a llist"} may return only finitely many @{const Skip}s before
    it has to decide on a @{const Done} or @{const Yield}. Then, we can define stream versions
    for all functions that can be defined by corecursion up-to. This in particular excludes
    @{const lfilter}. Moreover, we have to prove that every generator satisfies this
    restriction.
  \item A generator for @{typ "'a llist"} may return infinitely many @{const Skip}s in a row.
    Then, the @{text lunstream} function suffers from the same difficulties as @{const lfilter} with
    definitions, but we can define it using the least fixpoint approach described in
    \cite{LochbihlerHoelzl2014ITP}. Consequently, we can only fuse transformers that are monotone and
    continuous with respect to the ccpo ordering. This in particular excludes @{const lappend}.
  \end{itemize}
  Here, we take the both approaches where we consider the first preferable to the second.
  Consequently, we define producers such that they produce generators of the first kind, if possible.
  There will be multiple equations for transformers and consumers that deal with all the different
  combinations for their parameter generators. Transformers should yield generators of the first
  kind whenever possible. Consumers can be defined using @{text lunstream} and refined with custom
  code equations, i.e., they can operate with infinitely many @{text Skip}s in a row. We just
  have to lift the fusion equation to the first kind, too.
*}

type_synonym ('a, 's) lgenerator = "'s \<Rightarrow> ('a, 's) step"

inductive_set productive_on :: "('a, 's) lgenerator \<Rightarrow> 's set"
for g :: "('a, 's) lgenerator"
where
  Done: "g s = Done \<Longrightarrow> s \<in> productive_on g"
| Skip: "\<lbrakk> g s = Skip s'; s' \<in> productive_on g \<rbrakk> \<Longrightarrow> s \<in> productive_on g"
| Yield: "g s = Yield x s' \<Longrightarrow> s \<in> productive_on g"

definition productive :: "('a, 's) lgenerator \<Rightarrow> bool"
where "productive g \<longleftrightarrow> productive_on g = UNIV"

lemma productiveI [intro?]:
  "(\<And>s. s \<in> productive_on g) \<Longrightarrow> productive g"
by(auto simp add: productive_def)

lemma productive_onI [dest?]: "productive g \<Longrightarrow> s \<in> productive_on g"
by(simp add: productive_def)

text {* A type of generators that eventually will yield something else than a skip. *}

typedef ('a, 's) lgenerator' = "{g :: ('a, 's) lgenerator. productive g}"
  morphisms lgenerator Abs_lgenerator'
proof
  show "(\<lambda>_. Done) \<in> ?lgenerator'" by(auto intro: productive_on.intros productiveI)
qed

setup_lifting type_definition_lgenerator'

section {* Conversions to @{typ "'a llist"} *}

subsection {* Infinitely many consecutive @{term Skip}s *}

context fixes g :: "('a, 's) lgenerator" begin

partial_function (llist) lunstream :: "'s \<Rightarrow> 'a llist"
where
  "lunstream s = (case g s of
     Done \<Rightarrow> LNil | Skip s' \<Rightarrow> lunstream s' | Yield x s' \<Rightarrow> LCons x (lunstream s'))"

declare lunstream.simps[code]

lemma lunstream_simps:
  "g s = Done \<Longrightarrow> lunstream s = LNil"
  "g s = Skip s' \<Longrightarrow> lunstream s = lunstream s'"
  "g s = Yield x s' \<Longrightarrow> lunstream s = LCons x (lunstream s')"
by(simp_all add: lunstream.simps)

lemma lunstream_sels:
  shows lnull_lunstream: "lnull (lunstream s) \<longleftrightarrow>
  (case g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream: "lhd (lunstream s) =
  (case g s of Skip s' \<Rightarrow> lhd (lunstream s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream: "ltl (lunstream s) =
  (case g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream s') | Yield _ s' \<Rightarrow> lunstream s')"
by(simp_all add: lhd_def lunstream_simps split: step.split)

end

subsection {* Finitely many consecutive @{term Skip}s *}

lift_definition lunstream' :: "('a, 's) lgenerator' \<Rightarrow> 's \<Rightarrow> 'a llist"
is lunstream .

lemma lunstream'_simps:
  "lgenerator g s = Done \<Longrightarrow> lunstream' g s = LNil"
  "lgenerator g s = Skip s' \<Longrightarrow> lunstream' g s = lunstream' g s'"
  "lgenerator g s = Yield x s' \<Longrightarrow> lunstream' g s = LCons x (lunstream' g s')"
by(transfer, simp add: lunstream_simps)+

lemma lunstream'_sels:
  shows lnull_lunstream': "lnull (lunstream' g s) \<longleftrightarrow>
  (case lgenerator g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream' g s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream': "lhd (lunstream' g s) =
  (case lgenerator g s of Skip s' \<Rightarrow> lhd (lunstream' g s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream': "ltl (lunstream' g s) =
  (case lgenerator g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream' g s') | Yield _ s' \<Rightarrow> lunstream' g s')"
by(transfer, simp add: lunstream_sels)+

setup {* Context.theory_map (fold
  Stream_Fusion.add_unstream [@{const_name lunstream}, @{const_name lunstream'}]) *}

section {* Producers *}

subsection {* Conversion to streams *}

fun lstream :: "('a, 'a llist) lgenerator"
where
  "lstream LNil = Done"
| "lstream (LCons x xs) = Yield x xs"

lemma case_lstream_conv_case_llist:
  "(case lstream xs of Done \<Rightarrow> done | Skip xs' \<Rightarrow> skip xs' | Yield x xs' \<Rightarrow> yield x xs') =
   (case xs of LNil \<Rightarrow> done | LCons x xs' \<Rightarrow> yield x xs')"
by(simp split: llist.split)

lemma mcont2mcont_lunstream[THEN llist.mcont2mcont, simp, cont_intro]:
  shows mcont_lunstream: "mcont lSup lprefix lSup lprefix (lunstream lstream)"
by(rule llist.fixp_preserves_mcont1[OF lunstream.mono lunstream_def])(simp add: case_lstream_conv_case_llist)

lemma lunstream_lstream: "lunstream lstream xs = xs"
by(induction xs)(simp_all add: lunstream_simps)

lift_definition lstream' :: "('a, 'a llist) lgenerator'"
is lstream
proof
  fix s :: "'a llist"
  show "s \<in> productive_on lstream" by(cases s)(auto intro: productive_on.intros)
qed

lemma lunstream'_lstream: "lunstream' lstream' xs = xs"
by(transfer)(rule lunstream_lstream)

subsection {* @{const iterates} *}

definition iterates_raw :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator"
where "iterates_raw f s = Yield s (f s)"

lemma lunstream_iterates_raw: "lunstream (iterates_raw f) x = iterates f x"
by(coinduction arbitrary: x)(auto simp add: iterates_raw_def lunstream_sels)

lift_definition iterates_prod :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator'" is iterates_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: iterates_raw_def)

lemma lunstream'_iterates_prod [stream_fusion]: "lunstream' (iterates_prod f) x = iterates f x"
by transfer(rule lunstream_iterates_raw)

subsection {* @{const unfold_llist} *}

definition unfold_llist_raw :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator"
where
  "unfold_llist_raw stop head tail s = (if stop s then Done else Yield (head s) (tail s))"

lemma lunstream_unfold_llist_raw:
  "lunstream (unfold_llist_raw stop head tail) s = unfold_llist stop head tail s"
by(coinduction arbitrary: s)(auto simp add: lunstream_sels unfold_llist_raw_def)

lift_definition unfold_llist_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator'"
is unfold_llist_raw
proof(rule productiveI)
  fix stop and head :: "'a \<Rightarrow> 'b" and tail s
  show "s \<in> productive_on (unfold_llist_raw stop head tail)"
    by(cases "stop s")(auto intro: productive_on.intros simp add: unfold_llist_raw_def)
qed

lemma lunstream'_unfold_llist_prod [stream_fusion]:
  "lunstream' (unfold_llist_prod stop head tail) s = unfold_llist stop head tail s"
by transfer(rule lunstream_unfold_llist_raw)

subsection {* @{const inf_llist} *}

definition inf_llist_raw :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator"
where "inf_llist_raw f n = Yield (f n) (Suc n)"

lemma lunstream_inf_llist_raw: "lunstream (inf_llist_raw f) n = ldropn n (inf_llist f)"
by(coinduction arbitrary: n)(auto simp add: lunstream_sels inf_llist_raw_def)

lift_definition inf_llist_prod :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator'" is inf_llist_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: inf_llist_raw_def)

section {* Consumers *}

subsection {* @{const lhd} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lhd_cons :: "'s \<Rightarrow> 'a"
where [stream_fusion]: "lhd_cons s = lhd (lunstream g s)"

lemma lhd_cons_code[code]:
  "lhd_cons s = (case g s of Done \<Rightarrow> undefined | Skip s' \<Rightarrow> lhd_cons s' | Yield x _ \<Rightarrow> x)"
by(simp add: lhd_cons_def lunstream_simps lhd_def split: step.split)

end

lemma lhd_cons_fusion2 [stream_fusion]:
  "lhd_cons (lgenerator g) s = lhd (lunstream' g s)"
by transfer(rule lhd_cons_def)

subsection {* @{const llength} *}

context fixes g :: "('a, 's) lgenerator" begin

definition gen_llength_cons :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons n s = n + llength (lunstream g s)"

lemma gen_llength_cons_code [code]:
  "gen_llength_cons n s = (case g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons n s' | Yield _ s' \<Rightarrow> gen_llength_cons (eSuc n) s')"
by(simp add: gen_llength_cons_def lunstream_simps iadd_Suc_right iadd_Suc split: step.split)

lemma gen_llength_cons_fusion [stream_fusion]:
  "gen_llength_cons 0 s = llength (lunstream g s)"
by(simp add: gen_llength_cons_def)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition gen_llength_cons' :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons' = gen_llength_cons (lgenerator g)"

lemma gen_llength_cons'_code [code]:
  "gen_llength_cons' n s = (case lgenerator g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons' n s' | Yield _ s' \<Rightarrow> gen_llength_cons' (eSuc n) s')"
by(simp add: gen_llength_cons'_def cong: step.case_cong)(rule gen_llength_cons_code)

lemma gen_llength_cons'_fusion [stream_fusion]:
  "gen_llength_cons' 0 s = llength (lunstream' g s)"
by(simp add: gen_llength_cons'_def gen_llength_cons_fusion lunstream'.rep_eq)

end

subsection {* @{const lnull} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lnull_cons :: "'s \<Rightarrow> bool"
where [stream_fusion]: "lnull_cons s \<longleftrightarrow> lnull (lunstream g s)"

lemma lnull_cons_code [code]:
  "lnull_cons s \<longleftrightarrow> (case g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons_def lunstream_simps split: step.split)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition lnull_cons' :: "'s \<Rightarrow> bool"
where "lnull_cons' = lnull_cons (lgenerator g)"

lemma lnull_cons'_code [code]:
  "lnull_cons' s \<longleftrightarrow> (case lgenerator g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons' s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons'_def cong: step.case_cong)(rule lnull_cons_code)

lemma lnull_cons'_fusion [stream_fusion]:
  "lnull_cons' s \<longleftrightarrow> lnull (lunstream' g s)"
by(simp add: lnull_cons'_def lnull_cons_def lunstream'.rep_eq)

end

subsection {* @{const llist_all2} *}

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('b, 'sh) lgenerator"
  and P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
begin

definition llist_all2_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "llist_all2_cons sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream h sh)"

definition llist_all2_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "llist_all2_cons1 x sg' sh = llist_all2 P (LCons x (lunstream g sg')) (lunstream h sh)"

lemma llist_all2_cons_code [code]:
  "llist_all2_cons sg sh =
  (case g sg of
     Done \<Rightarrow> lnull_cons h sh
   | Skip sg' \<Rightarrow> llist_all2_cons sg' sh
   | Yield a sg' \<Rightarrow> llist_all2_cons1 a sg' sh)"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def llist_all2_cons1_def lunstream_simps lnull_def)

lemma llist_all2_cons1_code [code]:
  "llist_all2_cons1 x sg' sh =
  (case h sh of
     Done \<Rightarrow> False
   | Skip sh' \<Rightarrow> llist_all2_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> P x y \<and> llist_all2_cons sg' sh')"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def lnull_def llist_all2_cons1_def lunstream_simps)

end

lemma llist_all2_cons_fusion2 [stream_fusion]:
  "llist_all2_cons (lgenerator g) (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion3 [stream_fusion]:
  "llist_all2_cons g (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion4 [stream_fusion]:
  "llist_all2_cons (lgenerator g) h P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream h sh)"
by transfer(rule llist_all2_cons_def)

subsection {* @{const lnth} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lnth_cons :: "nat \<Rightarrow> 's \<Rightarrow> 'a"
where [stream_fusion]: "lnth_cons n s = lnth (lunstream g s) n"

lemma lnth_cons_code [code]:
  "lnth_cons n s = (case g s of
    Done \<Rightarrow> undefined n
  | Skip s' \<Rightarrow> lnth_cons n s'
  | Yield x s' \<Rightarrow> (if n = 0 then x else lnth_cons (n - 1) s'))"
by(cases n)(simp_all add: lnth_cons_def lunstream_simps lnth_LNil split: step.split)

end

subsection {* @{const lprefix} *}

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('a, 'sh) lgenerator"
begin

definition lprefix_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "lprefix_cons sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream h sh)"

definition lprefix_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "lprefix_cons1 x sg' sh \<longleftrightarrow> lprefix (LCons x (lunstream g sg')) (lunstream h sh)"

lemma lprefix_cons_code [code]:
  "lprefix_cons sg sh \<longleftrightarrow> (case g sg of
     Done \<Rightarrow> True | Skip sg' \<Rightarrow> lprefix_cons sg' sh | Yield x sg' \<Rightarrow> lprefix_cons1 x sg' sh)"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

lemma lprefix_cons1_code [code]:
  "lprefix_cons1 x sg' sh \<longleftrightarrow> (case h sh of
     Done \<Rightarrow> False | Skip sh' \<Rightarrow> lprefix_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> x = y \<and> lprefix_cons sg' sh')"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

end

lemma lprefix_cons_fusion2 [stream_fusion]:
  "lprefix_cons (lgenerator g) (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion3 [stream_fusion]:
  "lprefix_cons g (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion4 [stream_fusion]:
  "lprefix_cons (lgenerator g) h sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream h sh)"
by transfer(rule lprefix_cons_def)

section {* Transformers *}

subsection {* @{const lmap} *}

definition lmap_trans :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('b, 's) lgenerator"
where "lmap_trans = map_raw"

lemma lunstream_lmap_trans [stream_fusion]: fixes f g s
  defines [simp]: "g' \<equiv> lmap_trans f g"
  shows "lunstream g' s = lmap f (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    then show ?case
      by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
next
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
qed

lift_definition lmap_trans' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('b, 's) lgenerator'"
is lmap_trans
proof
  fix f :: "'a \<Rightarrow> 'b" and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (lmap_trans f g)"
    by induction(auto simp add: lmap_trans_def map_raw_def intro: productive_on.intros)
qed

lemma lunstream'_lmap_trans' [stream_fusion]:
  "lunstream' (lmap_trans' f g) s = lmap f (lunstream' g s)"
by transfer(rule lunstream_lmap_trans)

subsection {* @{const ltake} *}

fun ltake_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, (enat \<times> 's)) lgenerator"
where
  "ltake_trans g (n, s) =
  (if n = 0 then Done else case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s') | Yield a s' \<Rightarrow> Yield a (epred n, s'))"

lemma ltake_trans_fusion [stream_fusion]:
  fixes g' g
  defines [simp]: "g' \<equiv> ltake_trans g"
  shows "lunstream g' (n, s) = ltake n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s")(auto simp add: lunstream_simps neq_zero_conv_eSuc)
  qed simp_all
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s n rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s" n rule: step.exhaust[case_product enat_coexhaust])(auto simp add: lunstream_simps)
  qed simp_all
qed

lift_definition ltake_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, (enat \<times> 's)) lgenerator'"
is "ltake_trans"
proof
  fix g :: "('a, 's) lgenerator" and s :: "enat \<times> 's"
  obtain n sg where s: "s = (n, sg)" by(cases s)
  assume "productive g"
  hence "sg \<in> productive_on g" ..
  then show "s \<in> productive_on (ltake_trans g)" unfolding \<open>s = (n, sg)\<close>
    apply(induction arbitrary: n)
    apply(case_tac [!] n rule: enat_coexhaust)
    apply(auto intro: productive_on.intros)
    done
qed

lemma ltake_trans'_fusion [stream_fusion]:
  "lunstream' (ltake_trans' g) (n, s) = ltake n (lunstream' g s)"
by transfer(rule ltake_trans_fusion)

subsection {* @{const ldropn} *}

abbreviation (input) ldropn_trans :: "('b, 'a) lgenerator \<Rightarrow> ('b, nat \<times> 'a) lgenerator"
where "ldropn_trans \<equiv> drop_raw"

lemma ldropn_trans_fusion [stream_fusion]:
  fixes g defines [simp]: "g' \<equiv> ldropn_trans g"
  shows "lunstream g' (n, s) = ldropn n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s" n rule: step.exhaust[case_product nat.exhaust])
        (auto simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases n)(auto split: step.split simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
qed

lift_definition ldropn_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, nat \<times> 's) lgenerator'"
is ldropn_trans
proof
  fix g :: "('a, 's) lgenerator" and ns :: "nat \<times> 's"
  obtain n s where ns: "ns = (n, s)" by(cases ns)
  assume g: "productive g"
  show "ns \<in> productive_on (ldropn_trans g)" unfolding ns
  proof(induction n arbitrary: s)
    case 0
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros)
  next
    case (Suc n)
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros Suc.IH)
  qed
qed

lemma ldropn_trans'_fusion [stream_fusion]:
  "lunstream' (ldropn_trans' g) (n, s) = ldropn n (lunstream' g s)"
by transfer(rule ldropn_trans_fusion)

subsection {* @{const ldrop} *}

fun ldrop_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, enat \<times> 's) lgenerator"
where
  "ldrop_trans g (n, s) = (case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s')
  | Yield x s' \<Rightarrow> (if n = 0 then Yield x (n, s') else Skip (epred n, s')))"

lemma ldrop_trans_fusion [stream_fusion]:
  fixes g g' defines [simp]: "g' \<equiv> ldrop_trans g"
  shows "lunstream g' (n, s) = ldrop n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: n s rule: lunstream.fixp_induct)
      (auto simp add: lunstream_simps neq_zero_conv_eSuc elim: meta_allE[where x=0] split: step.split)
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case
      by(cases n rule: enat_coexhaust)(auto simp add: lunstream_simps split: step.split elim: meta_allE[where x=0])
  qed simp_all
qed

lemma ldrop_trans_fusion2 [stream_fusion]:
  "lunstream (ldrop_trans (lgenerator g)) (n, s) = ldrop n (lunstream' g s)"
by transfer (rule ldrop_trans_fusion)

subsection {* @{const ltakeWhile} *}

abbreviation (input) ltakeWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "ltakeWhile_trans \<equiv> takeWhile_raw"

lemma ltakeWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ltakeWhile_trans P g"
  shows "lunstream g' s = ltakeWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(auto simp add: lunstream_simps takeWhile_raw_def split: step.split)
  show "lprefix ?rhs ?lhs"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(auto split: step.split simp add: lunstream_simps takeWhile_raw_def)
qed

lift_definition ltakeWhile_trans' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('a, 's) lgenerator'"
is ltakeWhile_trans
proof
  fix P and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (ltakeWhile_trans P g)"
    apply(induction)
    apply(case_tac [3] "P x")
    apply(auto intro: productive_on.intros simp add: takeWhile_raw_def)
    done
qed

lemma ltakeWhile_trans'_fusion [stream_fusion]:
  "lunstream' (ltakeWhile_trans' P g) s = ltakeWhile P (lunstream' g s)"
by transfer(rule ltakeWhile_trans_fusion)

subsection {* @{const ldropWhile} *}

abbreviation (input) ldropWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) lgenerator \<Rightarrow> ('a, bool \<times> 'b) lgenerator"
where "ldropWhile_trans \<equiv> dropWhile_raw"

lemma ldropWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ldropWhile_trans P g"
  shows "lunstream g' (True, s) = ldropWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs" "lprefix (lunstream g' (False, s)) (lunstream g s)"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  moreover have "lprefix ?rhs ?lhs" "lprefix (lunstream g s) (lunstream g' (False, s))"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma ldropWhile_trans_fusion2 [stream_fusion]:
  "lunstream (ldropWhile_trans P (lgenerator g)) (True, s) = ldropWhile P (lunstream' g s)"
by transfer(rule ldropWhile_trans_fusion)

subsection {* @{const lzip} *}

abbreviation (input) lzip_trans :: "('a, 's1) lgenerator \<Rightarrow> ('b, 's2) lgenerator \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator"
where "lzip_trans \<equiv> zip_raw"

lemma lzip_trans_fusion [stream_fusion]:
  fixes g h gh defines [simp]: "gh \<equiv> lzip_trans g h"
  shows "lunstream gh (sg, sh, None) = lzip (lunstream g sg) (lunstream h sh)"
  (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs"
    and "\<And>x. lprefix (lunstream gh (sg, sh, Some x)) (lzip (LCons x (lunstream g sg)) (lunstream h sh))"
  proof(induction gh arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream)
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps) }
    { case 2 show ?case using 3
        by(cases "h sh")(simp_all add: lunstream_simps) }
  qed simp_all
  moreover
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  have "lprefix ?rhs ?lhs"
    and "\<And>x. lprefix (lzip (LCons x (lunstream g sg)) (lunstream h sh)) (lunstream gh (sg, sh, Some x))"
  proof(induction g arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    note IH = "3.IH"
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps fun_ord_def) }
    { case 2 show ?case
      proof(induction h arbitrary: sh sg x rule: lunstream.fixp_induct)
        case (3 unstream_h)
        thus ?case
        proof(cases "h sh")
          case (Yield y sh')
          thus ?thesis using "3.prems" IH "3.hyps"
            by(cases "g sg")(auto 4 3 simp add: lunstream_simps fun_ord_def intro: monotone_lzip2[THEN monotoneD] lprefix_trans)
        qed(simp_all add: lunstream_simps)
      qed simp_all }
  next
    case 2 case 2
    show ?case
      by(induction h arbitrary: sh rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  qed simp_all
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma lzip_trans_fusion2 [stream_fusion]:
  "lunstream (lzip_trans (lgenerator g) h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream h sh)"
by transfer(rule lzip_trans_fusion)

lemma lzip_trans_fusion3 [stream_fusion]:
  "lunstream (lzip_trans g (lgenerator h)) (sg, sh, None) = lzip (lunstream g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

lift_definition lzip_trans' :: "('a, 's1) lgenerator' \<Rightarrow> ('b, 's2) lgenerator' \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator'"
is "lzip_trans"
proof
  fix g :: "('a, 's1) lgenerator" and h :: "('b, 's2) lgenerator" and s :: "'s1 \<times> 's2 \<times> 'a option"
  assume "productive g" and "productive h"
  obtain sg sh mx where s: "s = (sg, sh, mx)" by(cases s)
  { fix x sg
    from \<open>productive h\<close> have "sh \<in> productive_on h" ..
    hence "(sg, sh, Some x) \<in> productive_on (lzip_trans g h)"
      by(induction)(auto simp add: intro: productive_on.intros) }
  moreover
  from \<open>productive g\<close> have "sg \<in> productive_on g" ..
  then have "(sg, sh, None) \<in> productive_on (lzip_trans g h)"
    by induction(auto intro: productive_on.intros calculation)
  ultimately show "s \<in> productive_on (lzip_trans g h)" unfolding s
    by(cases mx) auto
qed

lemma lzip_trans'_fusion [stream_fusion]:
  "lunstream' (lzip_trans' g h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

subsection {* @{const lappend} *}

lift_definition lappend_trans :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator"
is append_raw .

lemma lunstream_append_raw:
  fixes g h sh gh defines [simp]: "gh \<equiv> append_raw g h sh"
  assumes "productive g"
  shows "lunstream gh (Inl sg) = lappend (lunstream g sg) (lunstream h sh)"
proof(coinduction arbitrary: sg rule: llist.coinduct_strong)
  case (Eq_llist sg)
  { fix sh'
    have "lprefix (lunstream gh (Inr sh')) (lunstream h sh')"
      by(induction gh arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    moreover have "lprefix (lunstream h sh') (lunstream gh (Inr sh'))"
      by(induction h arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    ultimately have "lunstream gh (Inr sh') = lunstream h sh'"
      by(blast intro: lprefix_antisym) }
  note Inr = this[unfolded gh_def]
  from \<open>productive g\<close> have sg: "sg \<in> productive_on g" ..
  then show ?case by induction(auto simp add: lunstream_sels Inr)
qed

lemma lappend_trans_fusion [stream_fusion]:
  "lunstream (lappend_trans g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream h sh)"
by transfer(rule lunstream_append_raw)

lift_definition lappend_trans' :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator' \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator'"
is append_raw
proof
  fix g :: "('a, 'sg) lgenerator" and h :: "('a, 'sh) lgenerator" and sh s
  assume "productive g" "productive h"
  { fix sh'
    from \<open>productive h\<close> have "sh' \<in> productive_on h" ..
    then have "Inr sh' \<in> productive_on (append_raw g h sh)"
      by induction (auto intro: productive_on.intros)
  } moreover {
    fix sg
    from \<open>productive g\<close> have "sg \<in> productive_on g" ..
    then have "Inl sg \<in> productive_on (append_raw g h sh)"
      by induction(auto intro: productive_on.intros calculation) }
  ultimately show "s \<in> productive_on (append_raw g h sh)" by(cases s) auto
qed

lemma lappend_trans'_fusion [stream_fusion]:
  "lunstream' (lappend_trans' g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lunstream_append_raw)

subsection {* @{const lfilter} *}

definition lfilter_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "lfilter_trans = filter_raw"

lemma lunstream_lfilter_trans [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> lfilter_trans P g"
  shows "lunstream g' s = lfilter P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)
      (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
  show "lprefix ?rhs ?lhs"
  by(induction g arbitrary: s rule: lunstream.fixp_induct)
    (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
qed

lemma lunstream_lfilter_trans2 [stream_fusion]:
  "lunstream (lfilter_trans P (lgenerator g)) s = lfilter P (lunstream' g s)"
by transfer(rule lunstream_lfilter_trans)

subsection {* @{const llist_of} *}

lift_definition llist_of_trans :: "('a, 's) generator \<Rightarrow> ('a, 's) lgenerator'"
is "\<lambda>x. x"
proof
  fix g :: "('a, 's) raw_generator" and s
  assume "terminates g"
  hence "s \<in> terminates_on g" by(simp add: terminates_def)
  then show "s \<in> productive_on g"
    by(induction)(auto intro: productive_on.intros)
qed

lemma lunstream_llist_of_trans [stream_fusion]:
  "lunstream' (llist_of_trans g) s = llist_of (unstream g s)"
apply(induction s taking: g rule: unstream.induct)
apply(rule llist.expand)
apply(auto intro: llist.expand simp add: llist_of_trans.rep_eq lunstream_sels lunstream'.rep_eq split: step.split)
done

text {* We cannot define a stream version of @{const list_of} because we would have to test
  for finiteness first and therefore traverse the list twice. *}

end


theory UnionFind_Intf
imports  "SeprefTime.Sepref" UnionFind
begin

section "Union find Implementation"

subsection "MOP interface"

context
  fixes t ::  "nat \<Rightarrow> nat"
begin

  definition "mop_per_init n = SPECT [ per_init' n \<mapsto> enat (t n) ]"

  lemma progress_mop_per_init[progress_rules]: "t n > 0 \<Longrightarrow> progress (mop_per_init n)"
    unfolding mop_per_init_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  lemma mop_per_init: "tt \<le> lst (SPECT [ per_init' n \<mapsto> t n]) Q \<Longrightarrow> tt
           \<le> lst (mop_per_init n) Q" unfolding mop_per_init_def by simp

  sepref_register "mop_per_init"
end

context
  fixes t ::  "('a \<times> 'a) set \<Rightarrow> nat"
begin

  definition "mop_per_compare R a b = SPECT [ per_compare R a b \<mapsto> enat (t R) ]"

  sepref_register "mop_per_compare"
end

context
  fixes t ::  "('a \<times> 'a) set \<Rightarrow> nat"
begin

  definition "mop_per_union R a b = SPECT [ per_union R a b \<mapsto> enat (t R) ]"

  sepref_register "mop_per_union"
end

subsection "Implementation Locale"

type_synonym uf = "nat array \<times> nat array"

locale UnionFind_Impl =
  fixes is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn"
      and uf_init :: "nat \<Rightarrow> uf Heap"
      and uf_init_time :: "nat \<Rightarrow> nat"
      and uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap"
      and uf_cmp_time :: "nat \<Rightarrow> nat"
      and uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap"
      and uf_union_time :: "nat \<Rightarrow> nat"
    assumes
per_init'_sepref_rule[sepref_fr_rules]:  "\<And>t x' x. uf_init_time x' \<le> t x' \<Longrightarrow>
     hn_refine (hn_ctxt nat_assn x' x) (uf_init x)
         (hn_ctxt nat_assn x' x)
             is_uf (PR_CONST (mop_per_init t) $  x' )"

  and

per_compare_sepref_rule[sepref_fr_rules]:  "\<And>t R' R a' a b' b . uf_cmp_time (card (Domain R')) \<le> t R' \<Longrightarrow>
     hn_refine (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b) (uf_cmp R a b)
         (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b)
             bool_assn (PR_CONST (mop_per_compare t) $  R' $ a' $ b' )"

  and

per_union_sepref_rule[sepref_fr_rules]:  "\<And>t R' R a' a b' b . a' \<in> Domain R' \<Longrightarrow> b' \<in> Domain R'
  \<Longrightarrow> uf_union_time (card (Domain R')) \<le> t R' \<Longrightarrow>
     hn_refine (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b) (uf_union R a b)
         (hn_invalid is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b)
             is_uf (PR_CONST (mop_per_union t) $  R' $ a' $ b' )"

begin

thm per_init'_sepref_rule[to_hfref]
thm per_compare_sepref_rule[to_hfref]
thm per_union_sepref_rule[to_hfref]

end

end


(*  Title:      HOL/Auth/Guard/Guard_Public.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

Lemmas on guarded messages for public protocols.
*)

theory Guard_Public imports Guard "../Public" Extensions begin

subsection\<open>Extensions to Theory \<open>Public\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>signature\<close>

definition sign :: "agent => msg => msg" where
"sign A X == \<lbrace>Agent A, X, Crypt (priK A) (Hash X)\<rbrace>"

lemma sign_inj [iff]: "(sign A X = sign A' X') = (A=A' & X=X')"
by (auto simp: sign_def)

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == @A. K = priK A | K = pubK A"

lemma agt_priK [simp]: "agt (priK A) = A"
by (simp add: agt_def)

lemma agt_pubK [simp]: "agt (pubK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about @{term initState}\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X ~:parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X ~:analz (initState A)"
by auto

lemma no_priK_in_analz_init [simp]: "A ~:bad
==> Key (priK A) ~:analz (initState Spy)"
by (auto simp: initState.simps)

lemma priK_notin_initState_Friend [simp]: "A ~= Friend C
==> Key (priK A) ~: parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of private keys\<close>

definition priK_set :: "key set => bool" where
"priK_set Ks == ALL K. K:Ks --> (EX A. K = priK A)"

lemma in_priK_set: "[| priK_set Ks; K:Ks |] ==> EX A. K = priK A"
by (simp add: priK_set_def)

lemma priK_set1 [iff]: "priK_set {priK A}"
by (simp add: priK_set_def)

lemma priK_set2 [iff]: "priK_set {priK A, priK B}"
by (simp add: priK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set => bool" where
"good Ks == ALL K. K:Ks --> agt K ~:bad"

lemma in_good: "[| good Ks; K:Ks |] ==> agt K ~:bad"
by (simp add: good_def)

lemma good1 [simp]: "A ~:bad ==> good {priK A}"
by (simp add: good_def)

lemma good2 [simp]: "[| A ~:bad; B ~:bad |] ==> good {priK A, priK B}"
by (simp add: good_def)

subsubsection\<open>greatest nonce used in a trace, 0 if there is no nonce\<close>

primrec greatest :: "event list => nat"
where
  "greatest [] = 0"
| "greatest (ev # evs) = max (greatest_msg (msg ev)) (greatest evs)"

lemma greatest_is_greatest: "Nonce n:used evs ==> n <= greatest evs"
apply (induct evs, auto simp: initState.simps)
apply (drule used_sub_parts_used, safe)
apply (drule greatest_msg_is_greatest, arith)
by simp

subsubsection\<open>function giving a new nonce\<close>

definition new :: "event list => nat" where
"new evs == Suc (greatest evs)"

lemma new_isnt_used [iff]: "Nonce (new evs) ~:used evs"
by (clarify, drule greatest_is_greatest, auto simp: new_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack necessary because priK is defined as the inverse of pubK\<close>

lemma pubK_is_invKey_priK: "pubK A = invKey (priK A)"
by simp

lemmas pubK_is_invKey_priK_substI = pubK_is_invKey_priK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n:parts {X} ==> Crypt (pubK A) X:guard n {priK A}"
apply (rule pubK_is_invKey_priK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results\<close>

lemma sign_guard [intro]: "X:guard n Ks ==> sign A X:guard n Ks"
by (auto simp: sign_def)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
==> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n ~:used evs
==> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set => bool" where
"regular p == ALL evs A. evs:p --> (Key (priK A):parts (spies evs)) = (A:bad)"

lemma priK_parts_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):parts (spies evs)) = (A:bad)"
by (auto simp: regular_def)

lemma priK_analz_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):analz (spies evs)) = (A:bad)"
by auto

lemma Guard_Nonce_analz: "[| Guard n Ks (spies evs); evs:p;
priK_set Ks; good Ks; regular p |] ==> Nonce n ~:analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_priK_set, simp+, clarify)
apply (frule_tac A=A in priK_analz_iff_bad)
by (simp add: knows_decomp)+

end