(*  Title:       Hamming_Stream.thy
    Author:      Andreas Lochbihler, ETH Zurich
*)

section \<open>The Hamming stream defined as a least fixpoint\<close>

theory Hamming_Stream imports
  "../Coinductive_List"
  "HOL-Computational_Algebra.Primes"
begin

lemma infinity_inf_enat [simp]:
  fixes n :: enat
  shows "\<infinity> \<sqinter> n = n" "n \<sqinter> \<infinity> = n"
by(simp_all add: inf_enat_def)

lemma eSuc_inf_eSuc [simp]: "eSuc n \<sqinter> eSuc m = eSuc (n \<sqinter> m)"
by(simp add: inf_enat_def)

lemma if_pull2: "(if b then f x x' else f y y') = f (if b then x else y) (if b then x' else y')"
by simp

context ord begin

primcorec lmerge :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist"
where
  "lmerge xs ys =
   (case xs of LNil \<Rightarrow> LNil | LCons x xs' \<Rightarrow>
    case ys of LNil \<Rightarrow> LNil | LCons y ys' \<Rightarrow>
    if lhd xs < lhd ys then LCons x (lmerge xs' ys)
    else LCons y (if lhd ys < lhd xs then lmerge xs ys' else lmerge xs' ys'))"

lemma lnull_lmerge [simp]: "lnull (lmerge xs ys) \<longleftrightarrow> (lnull xs \<or> lnull ys)"
by(simp add: lmerge_def)

lemma lmerge_eq_LNil_iff: "lmerge xs ys = LNil \<longleftrightarrow> (xs = LNil \<or> ys = LNil)"
using lnull_lmerge unfolding lnull_def .

lemma lhd_lmerge: "\<lbrakk> \<not> lnull xs; \<not> lnull ys \<rbrakk> \<Longrightarrow> lhd (lmerge xs ys) = (if lhd xs < lhd ys then lhd xs else lhd ys)"
by(auto split: llist.split)

lemma ltl_lmerge:
  "\<lbrakk> \<not> lnull xs; \<not> lnull ys \<rbrakk> \<Longrightarrow>
  ltl (lmerge xs ys) =
  (if lhd xs < lhd ys then lmerge (ltl xs) ys
   else if lhd ys < lhd xs then lmerge xs (ltl ys)
   else lmerge (ltl xs) (ltl ys))"
by(auto split: llist.split)

declare lmerge.sel [simp del]

lemma lprefix_lmergeI:
  "\<lbrakk> lprefix xs xs'; lprefix ys ys' \<rbrakk>
  \<Longrightarrow> lprefix (lmerge xs ys) (lmerge xs' ys')"
by(coinduction arbitrary: xs xs' ys ys')(fastforce simp add: lhd_lmerge ltl_lmerge dest: lprefix_lhdD lprefix_lnullD simp add: not_lnull_conv split: if_split_asm)

lemma in_lset_lmergeD: "x \<in> lset (lmerge xs ys) \<Longrightarrow> x \<in> lset xs \<or> x \<in> lset ys"
by(induct zs\<equiv>"lmerge xs ys" arbitrary: xs ys rule: llist_set_induct)(auto simp add: lhd_lmerge ltl_lmerge split: if_split_asm dest: in_lset_ltlD)

lemma lset_lmerge: "lset (lmerge xs ys) \<subseteq> lset xs \<union> lset ys"
by(auto dest: in_lset_lmergeD)

lemma lfinite_lmergeD: "lfinite (lmerge xs ys) \<Longrightarrow> lfinite xs \<or> lfinite ys"
by(induct zs\<equiv>"lmerge xs ys" arbitrary: xs ys rule: lfinite_induct)(fastforce simp add: ltl_lmerge if_pull2 split: if_split_asm)+

lemma fixes F
  defines "F \<equiv> \<lambda>lmerge (xs, ys). case xs of LNil \<Rightarrow> LNil | LCons x xs' \<Rightarrow> case ys of LNil \<Rightarrow> LNil | LCons y ys' \<Rightarrow> (if x < y then LCons x (curry lmerge xs' ys) else if y < x then LCons y (curry lmerge xs ys') else LCons y (curry lmerge xs' ys'))"
  shows lmerge_conv_fixp: "lmerge \<equiv> curry (ccpo.fixp (fun_lub lSup) (fun_ord lprefix) F)" (is "?lhs \<equiv> ?rhs")
  and lmerge_mono: "mono_llist (\<lambda>lmerge. F lmerge xs)" (is "?mono xs")
proof(intro eq_reflection ext)
  show mono: "\<And>xs. ?mono xs" unfolding F_def by(tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)
  fix xs ys
  show "lmerge xs ys = ?rhs xs ys"
  proof(coinduction arbitrary: xs ys)
    case Eq_llist thus ?case
      by(subst (1 3 4) llist.mono_body_fixp[OF mono])(auto simp add: F_def lmerge_simps split: llist.split)
  qed
qed

lemma monotone_lmerge: "monotone (rel_prod lprefix lprefix) lprefix (case_prod lmerge)"
apply(rule llist.fixp_preserves_mono2[OF lmerge_mono lmerge_conv_fixp])
apply(erule conjE|rule allI conjI cont_intro|simp|erule allE, erule llist.mono2mono)+
done

lemma mono2mono_lmerge1 [THEN llist.mono2mono, cont_intro, simp]:
  shows monotone_lmerge1: "monotone lprefix lprefix (\<lambda>xs. lmerge xs ys)"
by(simp add: monotone_lmerge[simplified])

lemma mono2mono_lmerge2 [THEN llist.mono2mono, cont_intro, simp]:
  shows monotone_lmerge2: "monotone lprefix lprefix (\<lambda>ys. lmerge xs ys)"
by(simp add: monotone_lmerge[simplified])

lemma mcont_lmerge: "mcont (prod_lub lSup lSup) (rel_prod lprefix lprefix) lSup lprefix (case_prod lmerge)"
apply(rule llist.fixp_preserves_mcont2[OF lmerge_mono lmerge_conv_fixp])
apply(erule conjE|rule allI conjI cont_intro|simp|erule allE, erule llist.mcont2mcont)+
done

lemma mcont2mcont_lmerge1 [THEN llist.mcont2mcont, cont_intro, simp]:
  shows mcont_lmerge1: "mcont lSup lprefix lSup lprefix (\<lambda>xs. lmerge xs ys)"
by(simp add: mcont_lmerge[simplified])

lemma mcont2mcont_lmerge2 [THEN llist.mcont2mcont, cont_intro, simp]:
  shows mcont_lmerge2: "mcont lSup lprefix lSup lprefix (\<lambda>ys. lmerge xs ys)"
by(simp add: mcont_lmerge[simplified])

lemma lfinite_lmergeI [simp]: "\<lbrakk> lfinite xs; lfinite ys \<rbrakk> \<Longrightarrow> lfinite (lmerge xs ys)"
proof(induction arbitrary: ys rule: lfinite_induct)
  case (LCons xs)
  from LCons.prems LCons.hyps LCons.IH
  show ?case by induct(clarsimp simp add: not_lnull_conv lmerge_simps)+
qed simp

lemma linfinite_lmerge [simp]: "\<lbrakk> \<not> lfinite xs; \<not> lfinite ys \<rbrakk> \<Longrightarrow> \<not> lfinite (lmerge xs ys)"
by(auto dest: lfinite_lmergeD)

lemma llength_lmerge_above: "llength xs \<sqinter> llength ys \<le> llength (lmerge xs ys)"
proof(induction xs arbitrary: ys)
  case (LCons x xs)
  show ?case
  proof(induct ys)
    case LCons thus ?case using LCons.IH
      by(fastforce simp add: bot_enat_def[symmetric] lmerge_simps le_infI1 le_infI2 intro: order_trans[rotated])
  qed(simp_all add: bot_enat_def[symmetric])
qed(simp_all add: bot_enat_def[symmetric])

end

context linorder begin

lemma in_lset_lmergeI1:
  "\<lbrakk> x \<in> lset xs; lsorted xs; \<not> lfinite ys; \<exists>y\<in>lset ys. x \<le> y \<rbrakk>
  \<Longrightarrow> x \<in> lset (lmerge xs ys)"
proof(induction arbitrary: ys rule: lset_induct)
  case (find xs)
  then obtain y where "y \<in> lset ys" "x \<le> y" by blast
  thus ?case by induct(auto simp add: lmerge_simps not_less)
next
  case (step x' xs)
  then obtain y where "y \<in> lset ys" "x \<le> y" by blast
  moreover from \<open>lsorted (LCons x' xs)\<close> \<open>x \<in> lset xs\<close> \<open>x \<noteq> x'\<close>
  have "x' < x" "lsorted xs" by(auto simp add: lsorted_LCons)
  ultimately show ?case using \<open>\<not> lfinite ys\<close>
    by induct(auto 4 3 simp add: lmerge_simps \<open>x \<noteq> x'\<close> not_less intro: step.IH dest: in_lset_lmergeD)
qed

lemma in_lset_lmergeI2:
  "\<lbrakk> x \<in> lset ys; lsorted ys; \<not> lfinite xs; \<exists>y\<in>lset xs. x \<le> y \<rbrakk>
  \<Longrightarrow> x \<in> lset (lmerge xs ys)"
proof(induction arbitrary: xs rule: lset_induct)
  case (find ys)
  then obtain y where "y \<in> lset xs" "x \<le> y" by blast
  thus ?case by induct(auto simp add: lmerge_simps not_less)
next
  case (step x' ys)
  then obtain y where "y \<in> lset xs" "x \<le> y" by blast
  moreover from \<open>lsorted (LCons x' ys)\<close> \<open>x \<in> lset ys\<close> \<open>x \<noteq> x'\<close>
  have "x' < x" "lsorted ys" by(auto simp add: lsorted_LCons)
  ultimately show ?case using \<open>\<not> lfinite xs\<close>
    by induct(auto 4 3 simp add: lmerge_simps \<open>x \<noteq> x'\<close> not_less intro: step.IH dest: in_lset_lmergeD)
qed

lemma lsorted_lmerge: "\<lbrakk> lsorted xs; lsorted ys \<rbrakk> \<Longrightarrow> lsorted (lmerge xs ys)"
proof(coinduction arbitrary: xs ys)
  case (lsorted xs ys)
  have ?lhd using lsorted
    by(auto 4 3 simp add: not_lnull_conv lsorted_LCons lhd_lmerge ltl_lmerge dest!: in_lset_lmergeD)
  moreover have ?ltl using lsorted by(auto simp add: ltl_lmerge intro: lsorted_ltlI)
  ultimately show ?case ..
qed

lemma ldistinct_lmerge:
  "\<lbrakk> lsorted xs; lsorted ys; ldistinct xs; ldistinct ys \<rbrakk>
  \<Longrightarrow> ldistinct (lmerge xs ys)"
by(coinduction arbitrary: xs ys)(auto 4 3 simp add: lhd_lmerge ltl_lmerge not_lnull_conv lsorted_LCons not_less dest!: in_lset_lmergeD dest: antisym)

end

partial_function (llist) hamming' :: "unit \<Rightarrow> nat llist"
where
  "hamming' _ =
   LCons 1 (lmerge (lmap ((*) 2) (hamming' ())) (lmerge (lmap ((*) 3) (hamming' ())) (lmap ((*) 5) (hamming' ()))))"

definition hamming :: "nat llist"
where "hamming = hamming' ()"

lemma lnull_hamming [simp]: "\<not> lnull hamming"
unfolding hamming_def by(subst hamming'.simps) simp

lemma hamming_eq_LNil_iff [simp]: "hamming = LNil \<longleftrightarrow> False"
using lnull_hamming unfolding lnull_def by simp

lemma lhd_hamming [simp]: "lhd hamming = 1"
unfolding hamming_def by(subst hamming'.simps) simp

lemma ltl_hamming [simp]:
  "ltl hamming = lmerge (lmap ((*) 2) hamming) (lmerge (lmap ((*) 3) hamming) (lmap ((*) 5) hamming))"
unfolding hamming_def by(subst hamming'.simps) simp

lemma hamming_unfold:
  "hamming = LCons 1 (lmerge (lmap ((*) 2) hamming) (lmerge (lmap ((*) 3) hamming) (lmap ((*) 5) hamming)))"
by(rule llist.expand) simp_all

definition smooth :: "nat \<Rightarrow> bool"
where "smooth n \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> p dvd n \<longrightarrow> p \<le> 5)"

lemma smooth_0 [simp]: "\<not> smooth 0"
by(auto simp add: smooth_def intro: exI[where x=7])

lemma smooth_Suc0 [simp]: "smooth (Suc 0)"
by(auto simp add: smooth_def)

lemma smooth_gt0: "smooth n \<Longrightarrow> n > 0"
by(cases n) simp_all

lemma smooth_ge_Suc0: "smooth n \<Longrightarrow> n \<ge> Suc 0"
by(cases n) simp_all

lemma prime_nat_dvdD: "prime p \<Longrightarrow> (n :: nat) dvd p \<Longrightarrow> n = 1 \<or> n = p"
unfolding prime_nat_iff by simp

lemma smooth_times [simp]: "smooth (x * y) \<longleftrightarrow> smooth x \<and> smooth y"
by(auto simp add: smooth_def prime_dvd_mult_iff)

lemma smooth3 [simp]: "smooth 3"
by(auto simp add: smooth_def dest: prime_nat_dvdD[of 3, simplified])

lemma smooth5 [simp]: "smooth 5"
by(auto simp add: smooth_def dest: prime_nat_dvdD[of 5, simplified])

lemma hamming_in_smooth: "lset hamming \<subseteq> {n. smooth n}"
unfolding hamming_def by(induct rule: hamming'.fixp_induct)(auto 6 6 dest: in_lset_lmergeD)

lemma lfinite_hamming [simp]: "\<not> lfinite hamming"
proof
  assume "lfinite hamming"
  then obtain n where n: "llength hamming = enat n" unfolding lfinite_conv_llength_enat by fastforce
  have "llength (lmap ((*) 3) hamming) \<sqinter> llength (lmap ((*) 5) hamming) \<le> llength (lmerge (lmap ((*) 3) hamming) (lmap ((*) 5) hamming))"
    by(rule llength_lmerge_above)
  hence "llength hamming \<le> \<dots>" by simp
  moreover have "llength (lmap ((*) 2) hamming) \<sqinter> \<dots> \<le>
    llength (lmerge (lmap ((*) 2) hamming) (lmerge (lmap ((*) 3) hamming) (lmap ((*) 5) hamming)))"
    by(rule llength_lmerge_above)
  ultimately have "llength hamming \<le> \<dots>" by(simp add: inf.absorb1)
  also from n have "\<dots> < enat n"
    by(subst (asm) hamming_unfold)(cases n, auto simp add: zero_enat_def[symmetric] eSuc_enat[symmetric])
  finally show False unfolding n by simp
qed

lemma lsorted_hamming [simp]: "lsorted hamming"
  and ldistinct_hamming [simp]: "ldistinct hamming"
proof -
  have "lsorted hamming \<and> ldistinct hamming \<and> lset hamming \<subseteq> {1..}"
    unfolding hamming_def
    by(induct rule: hamming'.fixp_induct)(auto 6 6 simp add: lsorted_LCons dest: in_lset_lmergeD intro: smooth_ge_Suc0 lsorted_lmerge lsorted_lmap monotoneI ldistinct_lmerge inj_onI)
  thus "lsorted hamming" "ldistinct hamming" by simp_all
qed

lemma smooth_hamming:
  assumes "smooth n"
  shows "n \<in> lset hamming"
using assms
proof(induction n rule: less_induct)
  have [simp]:
    "monotone (\<le>) (\<le>) ((*) 2 :: nat \<Rightarrow> nat)"
    "monotone (\<le>) (\<le>) ((*) 3 :: nat \<Rightarrow> nat)"
    "monotone (\<le>) (\<le>) ((*) 5 :: nat \<Rightarrow> nat)"
    by(simp_all add: monotone_def)

  case (less n)
  show ?case
  proof(cases "n > 1")
    case False
    moreover from \<open>smooth n\<close> have "n \<noteq> 0" by(rule contrapos_pn) simp
    ultimately have "n = 1" by(simp)
    thus ?thesis by(subst hamming_unfold) simp
  next
    case True
    hence "\<exists>p. prime p \<and> p dvd n" by(metis less_numeral_extra(4) prime_factor_nat)
    with \<open>smooth n\<close> obtain p where "prime p" "p dvd n" "p \<le> 5" by(auto simp add: smooth_def)
    from \<open>p dvd n\<close> obtain n' where n: "n = p * n'" by(auto simp add: dvd_def)
    with \<open>smooth n\<close> \<open>prime p\<close> have "smooth n'" by(simp add: smooth_def)
    with \<open>prime p\<close> n have "n' < n" by(simp add: smooth_gt0 prime_gt_Suc_0_nat)
    hence n': "n' \<in> lset hamming" using \<open>smooth n'\<close> by(rule less.IH)

    from \<open>p \<le> 5\<close> have "p = 0 \<or> p = 1 \<or> p = 2 \<or> p = 3 \<or> p = 4 \<or> p = 5"
      by presburger
    with \<open>prime p\<close> have "p = 2 \<or> p = 3 \<or> p = 5" by auto
    thus ?thesis
    proof(elim disjE)
      assume "p = 2"
      with n n' show ?thesis
        by(subst hamming_unfold)(simp_all add: in_lset_lmergeI1 not_less lsorted_lmap bexI[where x="n'"] bexI[where x="3*n'"])
    next
      assume "p = 3"
      moreover with n \<open>smooth n'\<close> have "2 * n' < n" by(simp add: smooth_gt0)
      hence "2 * n' \<in> lset hamming" by(rule less.IH)(simp add: \<open>smooth n'\<close>)
      ultimately show ?thesis using n n'
        by(subst hamming_unfold)(auto 4 4 simp add: not_less lsorted_lmap lsorted_lmerge intro: in_lset_lmergeI1 in_lset_lmergeI2 bexI[where x="4*n'"] bexI[where x="5*n'"])
    next
      assume "p = 5"
      moreover with n \<open>smooth n'\<close> have "2 * (2 * n') < n" by(simp add: smooth_gt0)
      hence "2 * (2 * n') \<in> lset hamming" by(rule less.IH)(simp only: smooth_times smooth2 \<open>smooth n'\<close> simp_thms)
      moreover from \<open>p = 5\<close> n \<open>smooth n'\<close> have "3 * n' < n" by(simp add: smooth_gt0)
      hence "3 * n' \<in> lset hamming" by(rule less.IH)(simp add: \<open>smooth n'\<close>)
      ultimately show ?thesis using n n'
        by(subst hamming_unfold)(auto 4 4 simp add: lsorted_lmap lsorted_lmerge intro: in_lset_lmergeI2 bexI[where x="9*n'"] bexI[where x="8 * n'"])
    qed
  qed
qed

corollary hamming_smooth: "lset hamming = {n. smooth n}"
using hamming_in_smooth by(blast intro: smooth_hamming)

lemma hamming_THE:
  "(THE xs. lsorted xs \<and> ldistinct xs \<and> lset xs = {n. smooth n}) = hamming"
by(rule the_equality)(simp_all add: hamming_smooth lsorted_ldistinct_lset_unique)

end


theory Object
  imports
    Main Op "graphs/Digraph"
begin

section \<open>Version Graphs\<close>

text \<open>A version graph is a directed graph between versions, whose arcs (edges) are writes.\<close>

type_synonym "versionGraph" = "(version, aop) pre_digraph"

section \<open>Paths\<close>

text \<open>A path is a non-empty list of abstract writes such that each write's postversion connects to
the next write's preversion.\<close>

type_synonym "path" = "aop list"

primrec is_path :: "aop list \<Rightarrow> bool" where
"is_path [] = False" |
"is_path (w1 # ws) = (case ws of [] \<Rightarrow> True | (w2 # _) \<Rightarrow>
                      ((post_version w1) = (pre_version w2)) \<and> (is_path ws))"

lemma "is_path [AWrite k [0] 1 [1] [], AWrite k [1] 2 [2] []]"
  apply auto
  done

text \<open>We can also retrieve every version along a path, including the preversion of the first
write, and the postversion of the last write.\<close>

primrec path_versions :: "aop list \<Rightarrow> version list" where
"path_versions [] = []" |
"path_versions (w # ws) = ((apre_version w) # (map apost_version (w # ws)))"

text \<open>We say a path is in a version graph if every write in the path is in the version graph too.\<close>
primrec is_path_in_graph :: "aop list \<Rightarrow> versionGraph \<Rightarrow> bool" where
"is_path_in_graph [] g = True" |
"is_path_in_graph (w # ws) g = ((w \<in> (Digraph.arcs g)) \<and> (is_path_in_graph ws g))"

section \<open>Objects\<close>

text \<open>We define an Object as a key, an initial version, and a digraph over versions, where arcs
are writes."\<close>

datatype object = Object "key" "version" "versionGraph"

text \<open>Some basic accessors for objects\<close>

instantiation object :: keyed
begin
primrec key_object :: "object \<Rightarrow> key" where
"key_object (Object k i g) = k"
instance ..
end

primrec initial_version :: "object \<Rightarrow> version" where
"initial_version (Object k i g) = i"

primrec version_graph :: "object \<Rightarrow> versionGraph" where
"version_graph (Object k i g) = g"

instantiation object :: all_versions
begin
primrec all_versions_object :: "object \<Rightarrow> version set" where
"all_versions (Object k i g) = (Digraph.verts g)"
instance ..
end

instantiation object :: all_aops
begin
primrec all_aops_object :: "object \<Rightarrow> aop set" where
"all_aops_object (Object k i g) = (Digraph.arcs g)"
instance ..
end

section \<open>Traces\<close>

text \<open>A trace is a path in some object's version graph which connects the initial version to some
chosen version.\<close>

definition is_trace_of :: "object \<Rightarrow> path \<Rightarrow> version \<Rightarrow> bool" where
"is_trace_of obj p v \<equiv> ((is_path p) \<and>
                       (is_path_in_graph p (version_graph obj)) \<and>
                       ((initial_version obj) = (apre_version (hd p))) \<and>
                       (v = (apost_version (last p))))"

text \<open>We say an object is fully reachable if every element other than init has a trace.\<close>

definition is_fully_reachable :: "object \<Rightarrow> bool" where
"is_fully_reachable obj \<equiv> (\<forall>v. (v \<in> (all_versions obj)) \<longrightarrow> (\<exists>p. (is_trace_of obj p v)))"

text \<open>We can now define a well-formed object: they are fully reachable, and their initial version
is in the version graph. That second part might be redundant.\<close>

definition wf_object_init_in_graph :: "object \<Rightarrow> bool" where
"wf_object_init_in_graph obj \<equiv> ((initial_version obj) \<in> (all_versions obj))"

definition wf_object :: "object \<Rightarrow> bool" where
"wf_object obj \<equiv> (wf_object_init_in_graph obj) \<and>
                 (is_fully_reachable obj)"

text \<open>We might want to know the set of all operations which could result in some version.\<close>

definition awrites_of :: "object \<Rightarrow> version \<Rightarrow> aop set" where
"awrites_of obj v \<equiv> {w. w \<in> all_awrites obj \<and> v = apost_version w}"

text \<open>Now, we aim to include a new property: traceability\<close>

text \<open>Does this object have exactly one write resulting in a version?\<close>

definition version_has_only_one_write :: "object \<Rightarrow> version \<Rightarrow> bool" where
"version_has_only_one_write obj v \<equiv> (\<exists>!w. w \<in> awrites_of obj v)"

definition every_version_has_only_one_write :: "object \<Rightarrow> bool" where
"every_version_has_only_one_write obj \<equiv> (\<forall>v. (v \<in> (all_versions obj)) \<longrightarrow>
                                              (version_has_only_one_write obj v))"

definition every_version_has_at_most_one_write :: "object \<Rightarrow> bool" where
"every_version_has_at_most_one_write obj \<equiv> (\<forall>v. (v \<in> (all_versions obj)) \<longrightarrow>
                                                ((\<not>(\<exists>w. (apost_version w) = v)) \<or>
                                                (\<exists>!w. (apost_version w) = v)))"

text \<open>We say an object is traceable if it has exactly one trace for every version other than
the initial version.\<close>

definition is_traceable :: "object \<Rightarrow> bool" where
"is_traceable obj \<equiv> (\<forall>v. (v \<in> (all_versions obj) \<longrightarrow> (\<exists>!p. (is_trace_of obj p v))))"

(* I don't exactly understand the THE quantifier, but hopefully this works in conjunction with
traceable objects? *)
definition trace_of :: "object \<Rightarrow> version \<Rightarrow> path" where
"trace_of obj version \<equiv> (THE path. is_trace_of obj path version)"

text \<open>For traceable objects, we can define a trace_length for any version.\<close>

definition trace_length :: "object \<Rightarrow> version \<Rightarrow> nat" where
"trace_length obj v \<equiv> (length (trace_of obj v))"

subsection \<open>Implementations of objects\<close>

text \<open>Our digraphs need sets of vertices and arcs. We can write infinite sets, but for debugging and
examples, it's nice to think about finite domains. Let's construct the set of singleton lists up to
size s...\<close>
(* This throws a well-sortedness error value "{(v :: version). True}" *)

primrec nats_up_to :: "nat \<Rightarrow> nat list" where
"nats_up_to 0       = []" |
"nats_up_to (Suc n) = (n # (nats_up_to n))"
value "nats_up_to 2"

(* Takes a list and returns every variant of that list but starting with nats up to n. *)
definition tack_on_nats_up_to :: "nat \<Rightarrow> nat list \<Rightarrow> nat list list" where
"tack_on_nats_up_to n xs \<equiv> (map (\<lambda>x. (x # xs)) (nats_up_to n))"
value "tack_on_nats_up_to 3 (1 # [])"

(* Map and concatenate *)
definition mapcat :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
"mapcat f xs \<equiv> (concat (map f xs))"
value "mapcat nats_up_to (1 # 2 # 3 # [])"

(* Fixed lists *)
primrec lists_of_n_nats_up_to_m :: "nat \<Rightarrow> nat \<Rightarrow> nat list list" where
"lists_of_n_nats_up_to_m 0        m = ([] # [])" |
"lists_of_n_nats_up_to_m (Suc n)  m = (mapcat (tack_on_nats_up_to m) (lists_of_n_nats_up_to_m n m))"
value "lists_of_n_nats_up_to_m 2 2"

(* Variable lists *)
definition lists_of_nats_up_to :: "nat \<Rightarrow> nat list list" where
"lists_of_nats_up_to m \<equiv> (mapcat (\<lambda>n. (lists_of_n_nats_up_to_m (Suc n) m))
                                 (nats_up_to m))"

text \<open>Given a set of versions, an initial version, and a write function which takes a current
version and an argument to a resulting version and return value, we can build an object.\<close>

(*
 (AWrite k v1 a v2 r) | v1 a v2 r. (v1 \<in> domain) \<and>
                                   (v2 \<in> domain) \<and>
                                   (f v1 a) = (v2,r)},
*)

text \<open>We define a finite object constructor for debugging purposes--this version is executable.\<close>
definition smol_object :: "version list \<Rightarrow> writeArg list \<Rightarrow> version \<Rightarrow>
                           (version \<Rightarrow> writeArg \<Rightarrow> (version \<times> writeRet)) \<Rightarrow> key \<Rightarrow> object" where
"smol_object vs args init f k \<equiv> (Object k init
  \<lparr>verts = (set vs),
   arcs  = (set (mapcat (\<lambda>v1. (mapcat (\<lambda>v2. (mapcat (\<lambda>a.
                  (let (v2,r) = (f v1 a) in
                    (if (v2 \<in> (set vs)) then ((AWrite k v1 a v2 r) # []) else [])))
                  args)) vs)) vs)),
   tail  = apost_version,
   head  = apre_version\<rparr>)"

text \<open>And an object whose values are single-element sets up to the number n, such that writes
always overwrite the current value, and return values are always the empty list.\<close>

definition smol_register :: "nat \<Rightarrow> key \<Rightarrow> object" where
"smol_register n k \<equiv> (smol_object (lists_of_n_nats_up_to_m 1 n)
                                  (nats_up_to n)
                                  (0 # [])
                                  (\<lambda>ver arg. ((arg # []), []))
                                  k)"

value "smol_register 2 k"

text \<open>It's easier to prove properties of infinitely defined registers.\<close>

definition register :: "key \<Rightarrow> object" where
"register k \<equiv> (Object k [0] \<lparr>verts = {[v] | v. v \<in> Nats},
                             arcs  = {(AWrite k [v1] a [a] []) | v1 a. v1 \<in> Nats \<and> a \<in> Nats},
                             tail = apost_version,
                             head = apre_version\<rparr>)"

text \<open>We show that all finite registers can only reach values up to [n].\<close>

lemma "(all_versions (smol_register n k)) = (set (map (\<lambda>x.[x]) (nats_up_to n)))"
  apply (simp add:smol_register_def mapcat_def tack_on_nats_up_to_def
        nats_up_to_def smol_object_def)
  done

text \<open>And that finite nonempty registers are well-formed.\<close>

(* Not working yet
lemma "(0 < n) \<longrightarrow> wf_object (smol_register n k)"
  apply (simp add:wf_object_def wf_object_init_in_graph_def smol_register_def initial_version_def
         smol_object_def mapcat_def tack_on_nats_up_to_def nats_up_to_def)
  apply (induct_tac n)
   apply simp
  apply auto
  done

text \<open>The single-element register is traceable\<close>

lemma smol_singleton_register_traceable: "is_traceable (smol_register n k)"
  apply (simp add:is_traceable_def all_versions_def smol_register_def smol_object_def mapcat_def
tack_on_nats_up_to_def is_trace_of_def nats_up_to_def is_path_def is_path_in_graph_def
apre_version_def apost_version_def)
  (* huh not sure *)
  oops
*)

text \<open>The set of versions of an infinite register is all single-element lists.\<close>

lemma register_versions [simp]: "(all_versions (register k)) = {[x] | x. x \<in> Nats}"
  apply (simp add:register_def)
  done

lemma helper1: "(initial_version (register k)) = [0]"
  by (simp add: register_def)

lemma helper2: "AWrite k [0] (Suc 0) [Suc 0] [] \<in> arcs (version_graph (register k))"
  apply (simp add:register_def)
  by (metis Nats_1 One_nat_def)

lemma zero_in_N: "0 \<in> Nats"
  by auto

lemma n_in_N_implies_suc_in_N: "(n \<in> Nats) \<longrightarrow> (Suc n \<in> Nats)"
  by (metis (full_types) Nats_1 Nats_add One_nat_def add.right_neutral add_Suc_right)

(* REALLY? *)
lemma n_in_N [simp]: "(n::nat) \<in> Nats"
proof -
  obtain nn :: "(nat \<Rightarrow> bool) \<Rightarrow> nat" where
    f1: "\<forall>p n. (\<not> p 0 \<or> p (nn p) \<and> \<not> p (Suc (nn p))) \<or> p n"
    using nat_induct by moura
  have "(0::nat) \<in> \<nat> \<and> (nn (\<lambda>n. n \<in> \<nat>) \<notin> \<nat> \<or> Suc (nn (\<lambda>n. n \<in> \<nat>)) \<in> \<nat>)"
    using n_in_N_implies_suc_in_N by force
  then show ?thesis
    using f1 by (metis (no_types))
qed

(* I am... shocked this is this complicated *)
lemma succ_n_in_N [simp]: "(Suc n) \<in> Nats"
  by (simp add:n_in_N)

lemma helper3: "AWrite k [Suc 0] n [n] [] \<in> arcs (version_graph (register k))"
  by (simp add:register_def)

text \<open>There is a single-write trace to any version.\<close>

lemma register_one_trace: "is_trace_of (register k) [AWrite k [0] n [n] []] [n]"
  apply (simp add:is_trace_of_def register_def)
  done

text \<open>There is a second trace to any version going 0\<rightarrow>1\<rightarrow>v\<close>

lemma register_two_trace: "is_trace_of (register k) [(AWrite k [0] 1 [1] []),
                                                     (AWrite k [1] n [n] [])] [n]"
  unfolding is_trace_of_def
  apply auto
    apply (simp add:helper2)
   apply (simp add:helper3)
  by (simp add: helper1)

lemma register_has_a_trace: "\<exists>p. is_trace_of (register k) p [n]"
  using register_two_trace by blast

(* not working yet
lemma register_has_two_traces: "let r = (register k) in \<exists>p1 p2. (is_trace_of r p1 [n]) \<and>
                                                                (is_trace_of r p2 [n]) \<and>
                                                                (p \<noteq> q)"
proof-
  { fix x assume "x = 2" }
  using register_one_trace
  using register_two_trace

lemma register_not_traceable: "~(is_traceable (register k))"
  oops
*)

subsection \<open>Next, we define a construct for a list-append object. The initial value is the empty
list, and writes append an entry to the end of the list.\<close>

definition list_append :: "key \<Rightarrow> object" where
"list_append k \<equiv> (Object k [] \<lparr>verts = {l::(nat list). True},
                               arcs  = {(AWrite k v a (v @ [a]) []) | v a. a \<in> Nats },
                               tail  = apost_version,
                               head  = apre_version\<rparr>)"

text \<open>We wish to show that list append is traceable. We can show that a singleton list has a trace
if we feed that trace to the checker...\<close>

lemma list_append_singleton_list_has_trace_definite:
  "is_trace_of (list_append k) [(AWrite k [] x1 [x1] [])] [x1]"
  apply (simp add:is_trace_of_def list_append_def)
  done

text \<open>But... weirdly I can't figure out how to convince Isabelle that a trace DOES exist, even
though we just showed one exists. God, I wish I knew how to do proof by construction in Isabelle.\<close>

lemma list_append_singleton_list_has_trace: "\<exists>p. is_trace_of (list_append k) p [x1]"
  apply (simp add:is_trace_of_def list_append_def)
  oops

text \<open>And this is... right out.\<close>

lemma list_append_traceable: "is_traceable (list_append k)"
  oops

end


(*
  File: Dijkstra_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of Dijkstra's algorithm\<close>

theory Dijkstra_Impl
  imports Indexed_PQueue_Impl "../Functional/Dijkstra"
begin

text \<open>
  Imperative implementation of Dijkstra's shortest path algorithm. The
  algorithm is also verified by Nordhoff and Lammich in
  \cite{Dijkstra_Shortest_Path-AFP}.
\<close>

datatype dijkstra_state = Dijkstra_State (est_a: "nat array") (heap_pq: "nat indexed_pqueue")
setup \<open>add_simple_datatype "dijkstra_state"\<close>

fun dstate :: "state \<Rightarrow> dijkstra_state \<Rightarrow> assn" where
  "dstate (State e M) (Dijkstra_State a pq) = a \<mapsto>\<^sub>a e * idx_pqueue_map M (length e) pq"
setup \<open>add_rewrite_ent_rule @{thm dstate.simps}\<close>

subsection \<open>Basic operations\<close>

fun dstate_pq_init :: "graph \<Rightarrow> nat \<Rightarrow> nat indexed_pqueue Heap" where
  "dstate_pq_init G 0 = idx_pqueue_empty (size G)"
| "dstate_pq_init G (Suc k) = do {
    p \<leftarrow> dstate_pq_init G k;
    if k > 0 then update_idx_pqueue k (weight G 0 k) p
    else return p }"

lemma dstate_pq_init_to_fun [hoare_triple]:
  "k \<le> size G \<Longrightarrow>
   <emp>
   dstate_pq_init G k
   <idx_pqueue_map (map_constr (\<lambda>i. i > 0) (\<lambda>i. weight G 0 i) k) (size G)>\<^sub>t"
@proof @induct k @qed

definition dstate_init :: "graph \<Rightarrow> dijkstra_state Heap" where
  "dstate_init G = do {
     a \<leftarrow> Array.of_list (list (\<lambda>i. if i = 0 then 0 else weight G 0 i) (size G));
     pq \<leftarrow> dstate_pq_init G (size G);
     return (Dijkstra_State a pq)
   }"

lemma dstate_init_to_fun [hoare_triple]:
  "<emp>
   dstate_init G
   <dstate (dijkstra_start_state G)>\<^sub>t" by auto2

fun dstate_update_est :: "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat indexed_pqueue \<Rightarrow> nat array \<Rightarrow> nat array Heap" where
  "dstate_update_est G m 0 pq a = (return a)"
| "dstate_update_est G m (Suc k) pq a = do {
     b \<leftarrow> has_key_idx_pqueue k pq;
     if b then do {
       ek \<leftarrow> Array.nth a k;
       em \<leftarrow> Array.nth a m;
       a' \<leftarrow> dstate_update_est G m k pq a;
       a'' \<leftarrow> Array.upd k (min (em + weight G m k) ek) a';
       return a'' }
     else dstate_update_est G m k pq a }"

lemma dstate_update_est_ind [hoare_triple]:
  "k \<le> length e \<Longrightarrow> m < length e \<Longrightarrow>
   <a \<mapsto>\<^sub>a e * idx_pqueue_map M (length e) pq>
   dstate_update_est G m k pq a
   <\<lambda>r. dstate (State (list_update_set_impl (\<lambda>i. i \<in> keys_of M)
                      (\<lambda>i. min (e ! m + weight G m i) (e ! i)) e k) M) (Dijkstra_State r pq)>\<^sub>t"
@proof @induct k @qed

lemma dstate_update_est_to_fun [hoare_triple]:
  "<dstate (State e M) (Dijkstra_State a pq) * \<up>(m < length e)>
   dstate_update_est G m (length e) pq a
   <\<lambda>r. dstate (State (list_update_set (\<lambda>i. i \<in> keys_of M)
               (\<lambda>i. min (e ! m + weight G m i) (e ! i)) e) M) (Dijkstra_State r pq)>\<^sub>t" by auto2

fun dstate_update_heap ::
  "graph \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> nat indexed_pqueue \<Rightarrow> nat indexed_pqueue Heap" where
  "dstate_update_heap G m 0 a pq = return pq"
| "dstate_update_heap G m (Suc k) a pq = do {
     b \<leftarrow> has_key_idx_pqueue k pq;
     if b then do {
       ek \<leftarrow> Array.nth a k;
       pq' \<leftarrow> dstate_update_heap G m k a pq;
       update_idx_pqueue k ek pq' }
     else dstate_update_heap G m k a pq }"

lemma dstate_update_heap_ind [hoare_triple]:
  "k \<le> length e \<Longrightarrow> m < length e \<Longrightarrow>
   <a \<mapsto>\<^sub>a e * idx_pqueue_map M (length e) pq>
   dstate_update_heap G m k a pq
   <\<lambda>r. dstate (State e (map_update_all_impl (\<lambda>i. e ! i) M k)) (Dijkstra_State a r)>\<^sub>t"
@proof @induct k @qed

lemma dstate_update_heap_to_fun [hoare_triple]:
  "m < length e \<Longrightarrow>
   \<forall>i\<in>keys_of M. i < length e \<Longrightarrow>
   <dstate (State e M) (Dijkstra_State a pq)>
   dstate_update_heap G m (length e) a pq
   <\<lambda>r. dstate (State e (map_update_all (\<lambda>i. e ! i) M)) (Dijkstra_State a r)>\<^sub>t" by auto2

fun dijkstra_extract_min :: "dijkstra_state \<Rightarrow> (nat \<times> dijkstra_state) Heap" where
  "dijkstra_extract_min (Dijkstra_State a pq) = do {
     (x, pq') \<leftarrow> delete_min_idx_pqueue pq;
     return (fst x, Dijkstra_State a pq') }"

lemma dijkstra_extract_min_rule [hoare_triple]:
  "M \<noteq> empty_map \<Longrightarrow>
   <dstate (State e M) (Dijkstra_State a pq)>
   dijkstra_extract_min (Dijkstra_State a pq)
   <\<lambda>(m, r). dstate (State e (delete_map m M)) r * \<up>(m < length e) * \<up>(is_heap_min m M)>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm dstate.simps}\<close>

subsection \<open>Main operations\<close>

fun dijkstra_step_impl :: "graph \<Rightarrow> dijkstra_state \<Rightarrow> dijkstra_state Heap" where
  "dijkstra_step_impl G (Dijkstra_State a pq) = do {
     (x, S') \<leftarrow> dijkstra_extract_min (Dijkstra_State a pq);
     a' \<leftarrow> dstate_update_est G x (size G) (heap_pq S') (est_a S');
     pq'' \<leftarrow> dstate_update_heap G x (size G) a' (heap_pq S');
     return (Dijkstra_State a' pq'') }"

lemma dijkstra_step_impl_to_fun [hoare_triple]:
  "heap S \<noteq> empty_map \<Longrightarrow> inv G S \<Longrightarrow>
   <dstate S (Dijkstra_State a pq)>
   dijkstra_step_impl G (Dijkstra_State a pq)
   <\<lambda>r. \<exists>\<^sub>AS'. dstate S' r * \<up>(is_dijkstra_step G S S')>\<^sub>t" by auto2

lemma dijkstra_step_impl_correct [hoare_triple]:
  "heap S \<noteq> empty_map \<Longrightarrow> inv G S \<Longrightarrow>
   <dstate S p>
   dijkstra_step_impl G p
   <\<lambda>r. \<exists>\<^sub>AS'. dstate S' r * \<up>(inv G S') * \<up>(card (unknown_set S') = card (unknown_set S) - 1)>\<^sub>t" by auto2

fun dijkstra_loop :: "graph \<Rightarrow> nat \<Rightarrow> dijkstra_state \<Rightarrow> dijkstra_state Heap" where
  "dijkstra_loop G 0 p = (return p)"
| "dijkstra_loop G (Suc k) p = do {
    p' \<leftarrow> dijkstra_step_impl G p;
    p'' \<leftarrow> dijkstra_loop G k p';
    return p'' }"

lemma dijkstra_loop_correct [hoare_triple]:
  "<dstate S p * \<up>(inv G S) * \<up>(n \<le> card (unknown_set S))>
   dijkstra_loop G n p
   <\<lambda>r. \<exists>\<^sub>AS'. dstate S' r * \<up>(inv G S') * \<up>(card (unknown_set S') = card (unknown_set S) - n)>\<^sub>t"
@proof @induct n arbitrary S p @qed

definition dijkstra :: "graph \<Rightarrow> dijkstra_state Heap" where
  "dijkstra G = do {
    p \<leftarrow> dstate_init G;
    dijkstra_loop G (size G - 1) p }"

text \<open>Correctness of Dijkstra's algorithm.\<close>
theorem dijkstra_correct [hoare_triple]:
  "size G > 0 \<Longrightarrow>
   <emp>
   dijkstra G
   <\<lambda>r. \<exists>\<^sub>AS. dstate S r * \<up>(inv G S) * \<up>(unknown_set S = {}) *
        \<up>(\<forall>i\<in>verts G. has_dist G 0 i \<and> est S ! i = dist G 0 i)>\<^sub>t" by auto2

end


header {* Lassos *}
(* Author: Peter Lammich *)
theory Lasso
imports "Automata"
begin

  record 'v lasso =
    lasso_reach :: "'v list"
    lasso_va :: "'v"
    lasso_cysfx :: "'v list"

  definition "lasso_v0 L \<equiv> case lasso_reach L of [] \<Rightarrow> lasso_va L | (v0#_) \<Rightarrow> v0"
  definition lasso_cycle where "lasso_cycle L = lasso_va L # lasso_cysfx L"

  definition "lasso_of_prpl prpl \<equiv> case prpl of (pr,pl) \<Rightarrow> \<lparr>
    lasso_reach = pr,
    lasso_va = hd pl,
    lasso_cysfx = tl pl \<rparr>"

  definition "prpl_of_lasso L \<equiv> (lasso_reach L, lasso_va L # lasso_cysfx L)"

  lemma prpl_of_lasso_simps[simp]:
    "fst (prpl_of_lasso L) = lasso_reach L"
    "snd (prpl_of_lasso L) = lasso_va L # lasso_cysfx L"
    unfolding prpl_of_lasso_def by auto

  lemma lasso_of_prpl_simps[simp]:
    "lasso_reach (lasso_of_prpl prpl) = fst prpl"
    "snd prpl \<noteq> [] \<Longrightarrow> lasso_cycle (lasso_of_prpl prpl) = snd prpl"
    unfolding lasso_of_prpl_def lasso_cycle_def by (auto split: prod.split)

  definition run_of_lasso :: "'q lasso \<Rightarrow> 'q word"
    -- "Run described by a lasso"
    where "run_of_lasso L \<equiv> lasso_reach L \<frown> (lasso_cycle L)\<^sup>\<omega>"

  lemma run_of_lasso_of_prpl:
    "pl \<noteq> [] \<Longrightarrow> run_of_lasso (lasso_of_prpl (pr, pl)) = pr \<frown> pl\<^sup>\<omega>"
    unfolding run_of_lasso_def lasso_of_prpl_def lasso_cycle_def
    by auto

  definition "map_lasso f L \<equiv> \<lparr>
    lasso_reach = map f (lasso_reach L),
    lasso_va = f (lasso_va L),
    lasso_cysfx = map f (lasso_cysfx L)
  \<rparr>"

  lemma map_lasso_simps[simp]:
    "lasso_reach (map_lasso f L) = map f (lasso_reach L)"
    "lasso_va (map_lasso f L) = f (lasso_va L)"
    "lasso_cysfx (map_lasso f L) = map f (lasso_cysfx L)"
    "lasso_v0 (map_lasso f L) = f (lasso_v0 L)"
    "lasso_cycle (map_lasso f L) = map f (lasso_cycle L)"
    unfolding map_lasso_def lasso_v0_def lasso_cycle_def
    by (auto split: list.split)

  lemma map_lasso_run[simp]:
    shows "run_of_lasso (map_lasso f L) = f o (run_of_lasso L)"
    using assms
    apply (clarsimp
      simp: map_lasso_def run_of_lasso_def conc_def iter_def
      simp: lasso_cycle_def lasso_v0_def
      simp: nth_Cons'
      intro!: ext)

    apply (subst nth_map)
    apply (metis One_nat_def Suc_diff_1 Suc_less_SucD less_Suc_eq_0_disj
      semiring_numeral_div_class.pos_mod_bound)
    apply simp
    done

  context fr_graph begin
    definition is_lasso_pre :: "'v lasso \<Rightarrow> bool"
      where "is_lasso_pre L \<equiv>
        lasso_v0 L \<in> V0
      \<and> path E (lasso_v0 L) (lasso_reach L) (lasso_va L)
      \<and> path E (lasso_va L) (lasso_cycle L) (lasso_va L)"

    definition "is_lasso_prpl_pre prpl \<equiv> case prpl of (pr, pl) \<Rightarrow> \<exists>v0 va.
      v0\<in>V0
      \<and> pl \<noteq> []
      \<and> path E v0 pr va
      \<and> path E va pl va"

    lemma is_lasso_pre_prpl_of_lasso[simp]:
      "is_lasso_prpl_pre (prpl_of_lasso L) \<longleftrightarrow> is_lasso_pre L"
      unfolding is_lasso_pre_def prpl_of_lasso_def is_lasso_prpl_pre_def
      unfolding lasso_v0_def lasso_cycle_def
      by (auto simp: path_simps split: list.split)

    lemma is_lasso_prpl_pre_conv:
      "is_lasso_prpl_pre prpl
      \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso_pre (lasso_of_prpl prpl))"
      unfolding is_lasso_pre_def lasso_of_prpl_def is_lasso_prpl_pre_def
      unfolding lasso_v0_def lasso_cycle_def
      apply (cases prpl)
      apply (rename_tac a b)
      apply (case_tac b)
      apply (auto simp: path_simps split: list.splits)
      done

    lemma is_lasso_pre_empty[simp]: "V0 = {} \<Longrightarrow> \<not>is_lasso_pre L"
      unfolding is_lasso_pre_def by auto

    lemma run_of_lasso_pre:
      assumes "is_lasso_pre L"
      shows "is_run (run_of_lasso L)"
      and "run_of_lasso L 0 \<in> V0"
      using assms
      unfolding is_lasso_pre_def is_run_def run_of_lasso_def
        lasso_cycle_def lasso_v0_def
      by (auto simp: ipath_conc_conv ipath_iter_conv path_cons_conv conc_fst
        split: list.splits)

  end

  context gb_graph begin
    definition is_lasso
      :: "'Q lasso \<Rightarrow> bool"
      -- "Predicate that defines a lasso"
      where "is_lasso L \<equiv>
        is_lasso_pre L
      \<and> (\<forall>A\<in>F. (set (lasso_cycle L)) \<inter> A \<noteq> {})"

    definition "is_lasso_prpl prpl \<equiv>
      is_lasso_prpl_pre prpl
      \<and> (\<forall>A\<in>F. set (snd prpl) \<inter> A \<noteq> {})"

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply simp_all
      done

    lemma is_lasso_empty[simp]: "V0 = {} \<Longrightarrow> \<not>is_lasso L"
      unfolding is_lasso_def by auto

    lemma lasso_accepted:
      assumes L: "is_lasso L"
      shows "is_acc_run (run_of_lasso L)"
    proof -
      obtain "pr" va pls where
        [simp]: "L = \<lparr>lasso_reach = pr,lasso_va = va,lasso_cysfx = pls\<rparr>"
        by (cases L)

      from L have "is_run (run_of_lasso L)"
        unfolding is_lasso_def by (auto simp: run_of_lasso_pre)
      moreover from L have "(\<forall>A\<in>F. set (va#pls) \<inter> A \<noteq> {})"
        by (auto simp: is_lasso_def lasso_cycle_def)
      moreover from L have "(run_of_lasso L) 0 \<in> V0"
        unfolding is_lasso_def by (auto simp: run_of_lasso_pre)
      ultimately show "is_acc_run (run_of_lasso L)"
        unfolding is_acc_run_def is_acc_def run_of_lasso_def
          lasso_cycle_def lasso_v0_def
        by (fastforce intro: limit_inter_INF)
    qed

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr conc iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

  end

  context gb_graph
  begin
    lemma accepted_lasso:
      assumes A: "is_acc_run r"
      shows "\<exists>L. is_lasso L"
    proof -
      from A have
        RUN: "is_run r"
        and ACC: "\<forall>A\<in>F. limit r \<inter> A \<noteq> {}"
        by (auto simp: is_acc_run_limit_alt)
      from RUN have [simp]: "r 0 \<in> V0" and RUN': "ipath E r"
        by (simp_all add: is_run_def)

      txt {* Choose a node that is visited infinitely often *}
      from RUN have RAN_REACH: "range r \<subseteq> E\<^sup>*``V0"
        by (auto simp: is_run_def dest: ipath_to_rtrancl)
      hence "finite (range r)" by (auto intro: finite_subset)
      then obtain u where "u\<in>limit r" using limit_nonempty by blast
      hence U_REACH: "u\<in>E\<^sup>*``V0" using RAN_REACH limit_in_range by force
      then obtain v0 "pr" where PR: "v0\<in>V0" "path E v0 pr u"
        by (auto intro: rtrancl_is_path)
      moreover
      txt {* Build a path from @{text "u"} to @{text "u"}, that contains nodes from
        each acceptance set *}
      have "\<exists>pl. pl\<noteq>[] \<and> path E u pl u \<and> (\<forall>A\<in>F. set pl \<inter> A \<noteq> {})"
        using finite_F ACC
      proof (induction rule: finite_induct)
        case empty
        from run_limit_two_connectedI[OF RUN' `u\<in>limit r` `u\<in>limit r`]
        obtain p where [simp]: "p\<noteq>[]" and P: "path E u p u"
          by (rule trancl_is_path)
        thus ?case by blast
      next
        case (insert A F)
        from insert.IH insert.prems obtain pl where
          [simp]: "pl\<noteq>[]"
            and P: "path E u pl u"
            and ACC: "(\<forall>A'\<in>F. set pl \<inter> A' \<noteq> {})"
          by auto
        from insert.prems obtain v where VACC: "v\<in>A" "v\<in>limit r" by auto
        from run_limit_two_connectedI[OF RUN' `u\<in>limit r` `v\<in>limit r`]
        obtain p1 where [simp]: "p1\<noteq>[]"
          and P1: "path E u p1 v"
          by (rule trancl_is_path)

        from run_limit_two_connectedI[OF RUN' `v\<in>limit r` `u\<in>limit r`]
        obtain p2 where [simp]: "p2\<noteq>[]"
          and P2: "path E v p2 u"
          by (rule trancl_is_path)

        note P also note P1 also (path_conc) note P2 finally (path_conc)
        have "path E u (pl@p1@p2) u" by simp
        moreover from P2 have "v\<in>set (p1@p2)"
          by (cases p2) (auto simp: path_cons_conv)
        with ACC VACC have "(\<forall>A'\<in>insert A F. set (pl@p1@p2) \<inter> A' \<noteq> {})" by auto
        moreover have "pl@p1@p2 \<noteq> []" by auto
        ultimately show ?case by (intro exI conjI)
      qed
      then obtain pl where "pl \<noteq> []" "path E u pl u" "(\<forall>A\<in>F. set pl \<inter> A \<noteq> {})"
        by blast
      then obtain pls where "path E u (u#pls) u" "\<forall>A\<in>F. set (u#pls) \<inter> A \<noteq> {}"
        by (cases pl) (auto simp add: path_simps)
      ultimately show ?thesis
        apply -
        apply (rule
          exI[where x="\<lparr>lasso_reach = pr,lasso_va = u,lasso_cysfx = pls\<rparr>"])
        unfolding is_lasso_def lasso_v0_def lasso_cycle_def is_lasso_pre_def
        apply (cases "pr")
        apply (simp_all add: path_simps)
        done
    qed
  end

  context b_graph
  begin
    definition is_lasso where "is_lasso L \<equiv>
      is_lasso_pre L
      \<and> (set (lasso_cycle L)) \<inter> F \<noteq> {}"

    definition is_lasso_prpl where "is_lasso_prpl L \<equiv>
      is_lasso_prpl_pre L
      \<and> (set (snd L)) \<inter> F \<noteq> {}"

    lemma is_lasso_pre_ext[simp]:
      "gbg.is_lasso_pre T m = is_lasso_pre"
      unfolding gbg.is_lasso_pre_def[abs_def] is_lasso_pre_def[abs_def]
      unfolding to_gbg_ext_def
      by auto

    lemma is_lasso_gbg:
      "gbg.is_lasso T m = is_lasso"
      unfolding is_lasso_def[abs_def] gbg.is_lasso_def[abs_def]
      apply simp
      apply (auto simp: to_gbg_ext_def lasso_cycle_def)
      done

    lemmas lasso_accepted = gbg.lasso_accepted[unfolded to_gbg_alt is_lasso_gbg]
    lemmas accepted_lasso = gbg.accepted_lasso[unfolded to_gbg_alt is_lasso_gbg]

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply auto
      done

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr conc iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

  end

  context igb_graph begin
    definition "is_lasso L \<equiv>
      is_lasso_pre L
      \<and> (\<forall>i<num_acc. \<exists>q\<in>set (lasso_cycle L). i\<in>acc q)"

    definition "is_lasso_prpl L \<equiv>
      is_lasso_prpl_pre L
      \<and> (\<forall>i<num_acc. \<exists>q\<in>set (snd L). i\<in>acc q)"

    lemma is_lasso_prpl_of_lasso[simp]:
      "is_lasso_prpl (prpl_of_lasso L) \<longleftrightarrow> is_lasso L"
      unfolding is_lasso_def is_lasso_prpl_def
      unfolding lasso_v0_def lasso_cycle_def
      by auto

    lemma is_lasso_prpl_conv:
      "is_lasso_prpl prpl \<longleftrightarrow> (snd prpl\<noteq>[] \<and> is_lasso (lasso_of_prpl prpl))"
      unfolding is_lasso_def is_lasso_prpl_def is_lasso_prpl_pre_conv
      apply safe
      apply auto
      done

    lemma is_lasso_pre_ext[simp]:
      "gbg.is_lasso_pre T m = is_lasso_pre"
      unfolding gbg.is_lasso_pre_def[abs_def] is_lasso_pre_def[abs_def]
      unfolding to_gbg_ext_def
      by auto

    lemma is_lasso_gbg: "gbg.is_lasso T m = is_lasso"
      unfolding is_lasso_def[abs_def] gbg.is_lasso_def[abs_def]
      apply simp
      apply (simp_all add: to_gbg_ext_def)
      apply (intro ext)
      apply (fo_rule arg_cong | intro ext)+
      apply (auto simp: F_def accn_def intro!: ext)
      done

    lemmas lasso_accepted = gbg.lasso_accepted[unfolded to_gbg_alt is_lasso_gbg]
    lemmas accepted_lasso = gbg.accepted_lasso[unfolded to_gbg_alt is_lasso_gbg]

    lemma lasso_prpl_acc_run:
      "is_lasso_prpl (pr, pl) \<Longrightarrow> is_acc_run (pr conc iter pl)"
      apply (clarsimp simp: is_lasso_prpl_conv)
      apply (drule lasso_accepted)
      apply (simp add: run_of_lasso_of_prpl)
      done

    lemma degen_lasso_sound:
      assumes A: "degen.is_lasso T m L"
      shows "is_lasso (map_lasso fst L)"
    proof -

      from A have
        V0: "lasso_v0 L \<in> degen.V0 T m" and
        REACH: "path (degen.E T m)
                 (lasso_v0 L) (lasso_reach L) (lasso_va L)" and
        LOOP: "path (degen.E T m)
                  (lasso_va L) (lasso_cycle L) (lasso_va L)" and
        ACC: "(set (lasso_cycle L)) \<inter> degen.F T m \<noteq> {}"
        unfolding degen.is_lasso_def degen.is_lasso_pre_def by auto

      {
        fix i
        assume "i<num_acc"
        hence "\<exists>q\<in>set (lasso_cycle L). i \<in> local.acc (fst q) \<and> snd q = i"
        proof (induction i)
          case 0
          thus ?case using ACC unfolding degeneralize_ext_def by fastforce
        next
          case (Suc i)
          then obtain q where "(q,i)\<in>set (lasso_cycle L)" and "i\<in>acc q" by auto
          with LOOP obtain pl' where SPL: "set (lasso_cycle L) = set pl'"
            and PS: "path (degen.E T m) (q,i) pl' (q,i)"
            by (blast elim: path_loop_shift)
          from SPL have "pl'\<noteq>[]" by (auto simp: lasso_cycle_def)
          then obtain pl'' where [simp]: "pl'=(q,i)#pl''"
            using PS by (cases pl') (auto simp: path_simps)
          then obtain q2 pl''' where
            [simp]: "pl'' = (q2,(i + 1) mod num_acc)#pl'''"
            using PS `i\<in>acc q` `Suc i < num_acc`
            apply (cases pl'')
            apply (auto
              simp: path_simps degeneralize_ext_def
              split: split_if_asm)
            done
          from PS have
            "path (degen.E T m) (q2,Suc i) pl'' (q,i)"
            using `Suc i < num_acc`
            by (auto simp: path_simps)
          from degen_visit_acc[OF this] obtain qa
            where "(qa,Suc i)\<in>set pl''" "Suc i \<in> acc qa"
            by auto
          thus ?case
            by (rule_tac bexI[where x="(qa,Suc i)"]) (auto simp: SPL)
        qed
      } note aux=this

      from degen_V0_sound[OF V0]
        degen_path_sound[OF REACH]
        degen_path_sound[OF LOOP] aux
      show ?thesis
        unfolding is_lasso_def is_lasso_pre_def
        by auto
    qed

  end

  definition lasso_rel_ext_internal_def: "lasso_rel_ext Re R \<equiv> {
    (\<lparr> lasso_reach = r', lasso_va = va', lasso_cysfx = cysfx', \<dots>=m' \<rparr>,
     \<lparr> lasso_reach = r, lasso_va = va, lasso_cysfx = cysfx, \<dots>=m \<rparr>) |
      r' r va' va cysfx' cysfx m' m.
      (r',r) \<in> \<langle>R\<rangle>list_rel
    \<and> (va',va)\<in>R
    \<and> (cysfx', cysfx) \<in> \<langle>R\<rangle>list_rel
    \<and> (m',m) \<in> Re
    }"

  lemma lasso_rel_ext_def: "\<langle>Re,R\<rangle>lasso_rel_ext = {
    (\<lparr> lasso_reach = r', lasso_va = va', lasso_cysfx = cysfx', \<dots>=m' \<rparr>,
     \<lparr> lasso_reach = r, lasso_va = va, lasso_cysfx = cysfx, \<dots>=m \<rparr>) |
      r' r va' va cysfx' cysfx m' m.
      (r',r) \<in> \<langle>R\<rangle>list_rel
    \<and> (va',va)\<in>R
    \<and> (cysfx', cysfx) \<in> \<langle>R\<rangle>list_rel
    \<and> (m',m) \<in> Re
    }"
    unfolding lasso_rel_ext_internal_def relAPP_def by auto

  lemma lasso_rel_ext_sv[relator_props]:
    "\<lbrakk> single_valued Re; single_valued R \<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,R\<rangle>lasso_rel_ext)"
    unfolding lasso_rel_ext_def
    apply (rule single_valuedI)
    apply safe
    apply (blast dest: single_valuedD list_rel_sv[THEN single_valuedD])+
    done

  lemma lasso_rel_ext_id[relator_props]:
    "\<lbrakk> Re=Id; R=Id \<rbrakk> \<Longrightarrow> \<langle>Re,R\<rangle>lasso_rel_ext = Id"
    unfolding lasso_rel_ext_def
    apply simp
    apply safe
    by (metis lasso.surjective)

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

  lemmas [autoref_rel_intf] = REL_INTFI[of lasso_rel_ext i_lasso_ext]

  find_consts "(_,_) lasso_scheme"
  term lasso_reach_update

  lemma lasso_param[param, autoref_rules]:
    "(lasso_reach, lasso_reach) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "(lasso_va, lasso_va) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> R"
    "(lasso_cysfx, lasso_cysfx) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "(lasso_ext, lasso_ext)
      \<in> \<langle>R\<rangle>list_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Re \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "(lasso_reach_update, lasso_reach_update)
      \<in> (\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "(lasso_va_update, lasso_va_update)
      \<in> (R\<rightarrow>R) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "(lasso_cysfx_update, lasso_cysfx_update)
      \<in> (\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    "(lasso.more_update, lasso.more_update)
      \<in> (Re\<rightarrow>Re) \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext"
    unfolding lasso_rel_ext_def
    by (auto dest: fun_relD)

  lemma lasso_param2[param, autoref_rules]:
    "(lasso_v0, lasso_v0) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> R"
    "(lasso_cycle, lasso_cycle) \<in> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>R\<rangle>list_rel"
    "(map_lasso, map_lasso)
      \<in> (R\<rightarrow>R') \<rightarrow> \<langle>Re,R\<rangle>lasso_rel_ext \<rightarrow> \<langle>unit_rel,R'\<rangle>lasso_rel_ext"
    unfolding lasso_v0_def[abs_def] lasso_cycle_def[abs_def] map_lasso_def[abs_def]
    by parametricity+

  lemma lasso_of_prpl_param: "\<lbrakk>(l',l)\<in>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel; snd l \<noteq> []\<rbrakk>
    \<Longrightarrow> (lasso_of_prpl l', lasso_of_prpl l) \<in> \<langle>unit_rel,R\<rangle>lasso_rel_ext"
    unfolding lasso_of_prpl_def
    apply (cases l, cases l', clarsimp)
    apply (case_tac b, simp, case_tac ba, clarsimp_all)
    apply parametricity
    done

  context begin interpretation autoref_syn .

  lemma lasso_of_prpl_autoref[autoref_rules]:
    assumes "SIDE_PRECOND (snd l \<noteq> [])"
    assumes "(l',l)\<in>\<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel"
    shows "(lasso_of_prpl l',
      (OP lasso_of_prpl
        ::: \<langle>R\<rangle>list_rel \<times>\<^sub>r \<langle>R\<rangle>list_rel \<rightarrow> \<langle>unit_rel,R\<rangle>lasso_rel_ext)$l)
      \<in> \<langle>unit_rel,R\<rangle>lasso_rel_ext"
    using assms
    apply (simp add: lasso_of_prpl_param)
    done

  end

  subsection {* Implementing runs by lassos *}

  definition lasso_run_rel_def_internal:
    "lasso_run_rel R \<equiv> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
  lemma lasso_run_rel_def:
    "\<langle>R\<rangle>lasso_run_rel = br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
    unfolding lasso_run_rel_def_internal relAPP_def by simp

  lemma lasso_run_rel_sv[relator_props]:
    "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>lasso_run_rel)"
    unfolding lasso_run_rel_def
    by tagged_solver

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

  lemmas [autoref_rel_intf] = REL_INTFI[of lasso_run_rel i_run]

  definition [simp]: "op_map_run \<equiv> op o"

  lemma map_lasso_run_refine[autoref_rules]:
    shows "(map_lasso,op_map_run) \<in> (R\<rightarrow>R') \<rightarrow> \<langle>R\<rangle>lasso_run_rel \<rightarrow> \<langle>R'\<rangle>lasso_run_rel"
    unfolding lasso_run_rel_def op_map_run_def
  proof (intro fun_relI)
    fix f f' l r
    assume [param]: "(f,f')\<in>R\<rightarrow>R'" and
      "(l, r) \<in> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R)"
    then obtain r' where [param]: "(r',r)\<in>nat_rel \<rightarrow> R"
      and [simp]: "r' = run_of_lasso l"
      by (auto simp: br_def)

    have "(map_lasso f l, f o r') \<in> br run_of_lasso (\<lambda>_. True)"
      by (simp add: br_def)
    also have "(f o r', f' o r) \<in> nat_rel \<rightarrow> R'" by parametricity
    finally (relcompI) show
      "(map_lasso f l, f' o r) \<in> br run_of_lasso (\<lambda>_. True) O (nat_rel \<rightarrow> R')"
      .
  qed

end


(*  Title:      ZF/Induct/Ntree.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Datatype definition n-ary branching trees\<close>

theory Ntree imports Main begin

text \<open>
  Demonstrates a simple use of function space in a datatype
  definition.  Based upon theory \<open>Term\<close>.
\<close>

consts
  ntree :: "i => i"
  maptree :: "i => i"
  maptree2 :: "[i, i] => i"

datatype "ntree(A)" = Branch ("a \<in> A", "h \<in> (\<Union>n \<in> nat. n -> ntree(A))")
  monos UN_mono [OF subset_refl Pi_mono]  \<comment> \<open>MUST have this form\<close>
  type_intros nat_fun_univ [THEN subsetD]
  type_elims UN_E

datatype "maptree(A)" = Sons ("a \<in> A", "h \<in> maptree(A) -||> maptree(A)")
  monos FiniteFun_mono1  \<comment> \<open>Use monotonicity in BOTH args\<close>
  type_intros FiniteFun_univ1 [THEN subsetD]

datatype "maptree2(A, B)" = Sons2 ("a \<in> A", "h \<in> B -||> maptree2(A, B)")
  monos FiniteFun_mono [OF subset_refl]
  type_intros FiniteFun_in_univ'

definition
  ntree_rec :: "[[i, i, i] => i, i] => i"  where
  "ntree_rec(b) ==
    Vrecursor(\<lambda>pr. ntree_case(\<lambda>x h. b(x, h, \<lambda>i \<in> domain(h). pr`(h`i))))"

definition
  ntree_copy :: "i => i"  where
  "ntree_copy(z) == ntree_rec(\<lambda>x h r. Branch(x,r), z)"

text \<open>
  \medskip \<open>ntree\<close>
\<close>

lemma ntree_unfold: "ntree(A) = A \<times> (\<Union>n \<in> nat. n -> ntree(A))"
  by (blast intro: ntree.intros [unfolded ntree.con_defs]
    elim: ntree.cases [unfolded ntree.con_defs])

lemma ntree_induct [consumes 1, case_names Branch, induct set: ntree]:
  assumes t: "t \<in> ntree(A)"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  \<forall>i \<in> n. P(h`i)
      |] ==> P(Branch(x,h))"
  shows "P(t)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using t
  apply induct
  apply (erule UN_E)
  apply (assumption | rule step)+
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

lemma ntree_induct_eqn [consumes 1]:
  assumes t: "t \<in> ntree(A)"
    and f: "f \<in> ntree(A)->B"
    and g: "g \<in> ntree(A)->B"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  f O h = g O h |] ==>
      f ` Branch(x,h) = g ` Branch(x,h)"
  shows "f`t=g`t"
  \<comment> \<open>Induction on @{term "ntree(A)"} to prove an equation\<close>
  using t
  apply induct
  apply (assumption | rule step)+
  apply (insert f g)
  apply (rule fun_extension)
  apply (assumption | rule comp_fun)+
  apply (simp add: comp_fun_apply)
  done

text \<open>
  \medskip Lemmas to justify using \<open>Ntree\<close> in other recursive
  type definitions.
\<close>

lemma ntree_mono: "A \<subseteq> B ==> ntree(A) \<subseteq> ntree(B)"
  apply (unfold ntree.defs)
  apply (rule lfp_mono)
    apply (rule ntree.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemma ntree_univ: "ntree(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
  apply (unfold ntree.defs ntree.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (blast intro: Pair_in_univ nat_fun_univ [THEN subsetD])
  done

lemma ntree_subset_univ: "A \<subseteq> univ(B) ==> ntree(A) \<subseteq> univ(B)"
  by (rule subset_trans [OF ntree_mono ntree_univ])

text \<open>
  \medskip \<open>ntree\<close> recursion.
\<close>

lemma ntree_rec_Branch:
    "function(h) ==>
     ntree_rec(b, Branch(x,h)) = b(x, h, \<lambda>i \<in> domain(h). ntree_rec(b, h`i))"
  apply (rule ntree_rec_def [THEN def_Vrecursor, THEN trans])
  apply (simp add: ntree.con_defs rank_pair2 [THEN [2] lt_trans] rank_apply)
  done

lemma ntree_copy_Branch [simp]:
    "function(h) ==>
     ntree_copy (Branch(x, h)) = Branch(x, \<lambda>i \<in> domain(h). ntree_copy (h`i))"
  by (simp add: ntree_copy_def ntree_rec_Branch)

lemma ntree_copy_is_ident: "z \<in> ntree(A) ==> ntree_copy(z) = z"
  by (induct z set: ntree)
    (auto simp add: domain_of_fun Pi_Collect_iff fun_is_function)

text \<open>
  \medskip \<open>maptree\<close>
\<close>

lemma maptree_unfold: "maptree(A) = A \<times> (maptree(A) -||> maptree(A))"
  by (fast intro!: maptree.intros [unfolded maptree.con_defs]
    elim: maptree.cases [unfolded maptree.con_defs])

lemma maptree_induct [consumes 1, induct set: maptree]:
  assumes t: "t \<in> maptree(A)"
    and step: "!!x n h. [| x \<in> A;  h \<in> maptree(A) -||> maptree(A);
                  \<forall>y \<in> field(h). P(y)
               |] ==> P(Sons(x,h))"
  shows "P(t)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using t
  apply induct
  apply (assumption | rule step)+
  apply (erule Collect_subset [THEN FiniteFun_mono1, THEN subsetD])
  apply (drule FiniteFun.dom_subset [THEN subsetD])
  apply (drule Fin.dom_subset [THEN subsetD])
  apply fast
  done

text \<open>
  \medskip \<open>maptree2\<close>
\<close>

lemma maptree2_unfold: "maptree2(A, B) = A \<times> (B -||> maptree2(A, B))"
  by (fast intro!: maptree2.intros [unfolded maptree2.con_defs]
    elim: maptree2.cases [unfolded maptree2.con_defs])

lemma maptree2_induct [consumes 1, induct set: maptree2]:
  assumes t: "t \<in> maptree2(A, B)"
    and step: "!!x n h. [| x \<in> A;  h \<in> B -||> maptree2(A,B);  \<forall>y \<in> range(h). P(y)
               |] ==> P(Sons2(x,h))"
  shows "P(t)"
  using t
  apply induct
  apply (assumption | rule step)+
   apply (erule FiniteFun_mono [OF subset_refl Collect_subset, THEN subsetD])
   apply (drule FiniteFun.dom_subset [THEN subsetD])
   apply (drule Fin.dom_subset [THEN subsetD])
   apply fast
   done

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Galois Property\<close>
theory Galois_Property
  imports
    Half_Galois_Property
begin

context galois_prop
begin

definition "galois_prop \<equiv> ((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) \<sqinter> ((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>))"

notation galois_prop.galois_prop (infix "\<unlhd>" 50)

lemma galois_propI [intro]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding galois_prop_def using assms by auto

lemma galois_propI':
  assumes "\<And>x y. in_dom (\<le>\<^bsub>L\<^esub>) x \<Longrightarrow> in_codom (\<le>\<^bsub>R\<^esub>) y \<Longrightarrow> x \<le>\<^bsub>L\<^esub> r y \<longleftrightarrow> l x \<le>\<^bsub>R\<^esub> y"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by blast

lemma galois_propE [elim]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  obtains "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r" "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  using assms unfolding galois_prop_def by auto

interpretation g : galois_prop S T f g for S T f g.

lemma galois_prop_eq_half_galois_prop_left_rel_inf_half_galois_prop_right:
  "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) = ((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) \<sqinter> ((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>))"
  by (intro ext) auto

lemma galois_prop_left_rel_right_iff_left_right_rel:
  assumes "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "in_dom (\<le>\<^bsub>L\<^esub>) x" "in_codom (\<le>\<^bsub>R\<^esub>) y"
  shows "x \<le>\<^bsub>L\<^esub> r y \<longleftrightarrow> l x \<le>\<^bsub>R\<^esub> y"
  using assms by blast

lemma rel_inv_galois_prop_eq_galois_prop_rel_inv [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<unlhd> (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<ge>\<^bsub>L\<^esub>) \<unlhd> (\<ge>\<^bsub>R\<^esub>))"
  by (intro ext) blast

corollary galois_prop_rel_inv_iff_galois_prop [iff]:
  "((\<ge>\<^bsub>L\<^esub>) \<unlhd> (\<ge>\<^bsub>R\<^esub>)) f g \<longleftrightarrow> ((\<le>\<^bsub>R\<^esub>) \<unlhd> (\<le>\<^bsub>L\<^esub>)) g f"
  by auto

end

context galois
begin

lemma galois_prop_left_right_if_transitive_if_deflationary_on_if_inflationary_on_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l" and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "inflationary_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  and "deflationary_on (in_codom (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (intro galois_propI
    half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel
    half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel)

end

end


section \<open>Negation procedure\<close>
theory Negation
imports Data Evaluate
begin

text \<open>To compute the negation of a function f one merely needs to flip the values in the leaves.
      Hence, one should be able to merely lazily remap the original BDD nodes into the same with
      leaves negated.\<close>

fun negate :: \<open>'l node \<Rightarrow> 'l node\<close> where
  \<open>negate (N u l h) = (let l' = (case l of Leaf b \<Rightarrow> Leaf (\<not>b) | _ \<Rightarrow> l)
                         ; h' = (case h of Leaf b \<Rightarrow> Leaf (\<not>b) | _ \<Rightarrow> h)
                        in N u l' h')\<close>

fun bdd_not :: \<open>'l bdd \<Rightarrow> 'l bdd\<close> where
  \<open>bdd_not (Constant b) = (Constant (\<not>b))\<close>
| \<open>bdd_not (Nodes ns)   = (Nodes (map negate ns))\<close>

lemma bdd_not_correct_aux:
  assumes \<open>closed ns\<close> \<open>tgt \<in> uid ` set ns\<close>
  shows \<open>\<not>bdd_eval_node ns a tgt \<longleftrightarrow> bdd_eval_node (map negate ns) a tgt\<close>
  using assms by (induction ns arbitrary: tgt rule: nl_induct) (auto split: ptr.splits)

theorem bdd_not_correct:
  assumes \<open>well_formed bdd\<close>
  shows \<open>\<not>bdd_eval bdd a \<longleftrightarrow> bdd_eval (bdd_not bdd) a\<close>
  using assms bdd_not_correct_aux
  by (cases bdd rule: bdd_cases; force split:ptr.splits dest!: closed_if_well_formed_nl)

end