(*  Title:       Terminated coinductive list
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

section {* Terminated coinductive lists and their operations *}

theory TLList imports
  Coinductive_List
begin

text {*
  Terminated coinductive lists @{text "('a, 'b) tllist"} are the codatatype defined by the construtors
  @{text "TNil"} of type @{text "'b \<Rightarrow> ('a, 'b) tllist"} and
  @{text "TCons"} of type @{text "'a \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"}.
*}

subsection {* Auxiliary lemmas *}

lemma split_fst: "R (fst p) = (\<forall>x y. p = (x, y) \<longrightarrow> R x)"
by(cases p) simp

lemma split_fst_asm: "R (fst p) \<longleftrightarrow> (\<not> (\<exists>x y. p = (x, y) \<and> \<not> R x))"
by(cases p) simp

subsection {* Type definition *}

consts terminal0 :: "'a"

codatatype (tset: 'a, 'b) tllist =
    TNil (terminal : 'b)
  | TCons (thd : 'a) (ttl : "('a, 'b) tllist")
for
  map: tmap
  rel: tllist_all2
where
  "thd (TNil _) = undefined"
| "ttl (TNil b) = TNil b"
| "terminal (TCons _ xs) = terminal0 xs"

overloading
  terminal0 == "terminal0::('a, 'b) tllist \<Rightarrow> 'b"
begin

partial_function (tailrec) terminal0
where "terminal0 xs = (if is_TNil xs then case_tllist id undefined xs else terminal0 (ttl xs))"

end

lemma terminal0_terminal [simp]: "terminal0 = terminal"
apply(rule ext)
apply(subst terminal0.simps)
apply(case_tac x)
apply(simp_all add: terminal_def)
done

lemmas terminal_TNil [code, nitpick_simp] = tllist.sel(1)

lemma terminal_TCons [simp, code, nitpick_simp]: "terminal (TCons x xs) = terminal xs"
by simp

declare tllist.sel(2) [simp del]

primcorec unfold_tllist :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('c, 'b) tllist" where
  "p a \<Longrightarrow> unfold_tllist p g1 g21 g22 a = TNil (g1 a)" |
  "_ \<Longrightarrow> unfold_tllist p g1 g21 g22 a =
     TCons (g21 a) (unfold_tllist p g1 g21 g22 (g22 a))"

declare
  unfold_tllist.ctr(1) [simp]
  tllist.corec(1) [simp]

subsection {* Code generator setup *}

text {* Test quickcheck setup *}

lemma "xs = TNil x"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "TCons x xs = TCons x xs"
quickcheck[narrowing, expect=no_counterexample]
oops

text {* More lemmas about generated constants *}

lemma is_TNil_ttl [simp]: "is_TNil xs \<Longrightarrow> is_TNil (ttl xs)"
by(cases xs) simp_all

lemma terminal_ttl [simp]: "terminal (ttl xs) = terminal xs"
by(cases xs) simp_all

lemma unfold_tllist_eq_TNil [simp]:
  "unfold_tllist IS_TNIL TNIL THD TTL a = TNil b \<longleftrightarrow> IS_TNIL a \<and> b = TNIL a"
by(auto simp add: unfold_tllist.code)

lemma TNil_eq_unfold_tllist [simp]:
  "TNil b = unfold_tllist IS_TNIL TNIL THD TTL a \<longleftrightarrow> IS_TNIL a \<and> b = TNIL a"
by(auto simp add: unfold_tllist.code)

lemma tmap_is_TNil: "is_TNil xs \<Longrightarrow> tmap f g xs = TNil (g (terminal xs))"
by(clarsimp simp add: is_TNil_def)

declare tllist.map_sel(2)[simp]

lemma ttl_tmap [simp]: "ttl (tmap f g xs) = tmap f g (ttl xs)"
by(cases xs) simp_all

lemma TNil_eq_tmap_conv:
  "TNil y = tmap f g xs \<longleftrightarrow> (\<exists>y'. xs = TNil y' \<and> g y' = y)"
by(cases xs) auto

declare tllist.set_sel(1)[simp]

lemma tset_ttl: "tset (ttl xs) \<subseteq> tset xs"
by(cases xs) auto

lemma in_tset_ttlD: "x \<in> tset (ttl xs) \<Longrightarrow> x \<in> tset xs"
using tset_ttl[of xs] by auto

theorem tllist_set_induct[consumes 1, case_names find step]:
  assumes "x \<in> tset xs" and "\<And>xs. \<not> is_TNil xs \<Longrightarrow> P (thd xs) xs"
  and "\<And>xs y. \<lbrakk>\<not> is_TNil xs; y \<in> tset (ttl xs); P y (ttl xs)\<rbrakk> \<Longrightarrow> P y xs"
  shows "P x xs"
using assms by(induct)(fastforce simp del: tllist.disc(2) iff: tllist.disc(2), auto)

theorem set2_tllist_induct[consumes 1, case_names find step]:
  assumes "x \<in> set2_tllist xs" and "\<And>xs. is_TNil xs \<Longrightarrow> P (terminal xs) xs"
  and "\<And>xs y. \<lbrakk>\<not> is_TNil xs; y \<in> set2_tllist (ttl xs); P y (ttl xs)\<rbrakk> \<Longrightarrow> P y xs"
  shows "P x xs"
using assms by(induct)(fastforce simp del: tllist.disc(1) iff: tllist.disc(1), auto)

subsection {* Connection with @{typ "'a llist"} *}

context fixes b :: 'b begin
primcorec tllist_of_llist :: "'a llist \<Rightarrow> ('a, 'b) tllist" where
  "tllist_of_llist xs = (case xs of LNil \<Rightarrow> TNil b | LCons x xs' \<Rightarrow> TCons x (tllist_of_llist xs'))"
end

primcorec llist_of_tllist :: "('a, 'b) tllist \<Rightarrow> 'a llist"
where "llist_of_tllist xs = (case xs of TNil _ \<Rightarrow> LNil | TCons x xs' \<Rightarrow> LCons x (llist_of_tllist xs'))"

simps_of_case tllist_of_llist_simps [simp, code, nitpick_simp]: tllist_of_llist.code

lemmas tllist_of_llist_LNil = tllist_of_llist_simps(1)
  and tllist_of_llist_LCons = tllist_of_llist_simps(2)

lemma terminal_tllist_of_llist_lnull [simp]:
  "lnull xs \<Longrightarrow> terminal (tllist_of_llist b xs) = b"
unfolding lnull_def by simp

declare tllist_of_llist.sel(1)[simp del]

lemma lhd_LNil: "lhd LNil = undefined"
by(simp add: lhd_def)

lemma thd_TNil: "thd (TNil b) = undefined"
by(simp add: thd_def)

lemma ttl_tllist_of_llist [simp]: "ttl (tllist_of_llist b xs) = tllist_of_llist b (ltl xs)"
by(cases xs) simp_all

lemma llist_of_tllist_eq_LNil:
  "llist_of_tllist xs = LNil \<longleftrightarrow> is_TNil xs"
using llist_of_tllist.disc_iff(1) unfolding lnull_def .

simps_of_case llist_of_tllist_simps [simp, code, nitpick_simp]: llist_of_tllist.code

lemmas llist_of_tllist_TNil = llist_of_tllist_simps(1)
  and llist_of_tllist_TCons = llist_of_tllist_simps(2)

declare llist_of_tllist.sel [simp del]

lemma lhd_llist_of_tllist [simp]: "\<not> is_TNil xs \<Longrightarrow> lhd (llist_of_tllist xs) = thd xs"
by(cases xs) simp_all

lemma ltl_llist_of_tllist [simp]:
  "ltl (llist_of_tllist xs) = llist_of_tllist (ttl xs)"
by(cases xs) simp_all

lemma tllist_of_llist_cong [cong]:
  assumes "xs = xs'" "lfinite xs' \<Longrightarrow> b = b'"
  shows "tllist_of_llist b xs = tllist_of_llist b' xs'"
proof(unfold `xs = xs'`)
  from assms have "lfinite xs' \<longrightarrow> b = b'" by simp
  thus "tllist_of_llist b xs' = tllist_of_llist b' xs'"
    by(coinduction arbitrary: xs') auto
qed

lemma llist_of_tllist_inverse [simp]:
  "tllist_of_llist (terminal b) (llist_of_tllist b) = b"
by(coinduction arbitrary: b) simp_all

lemma tllist_of_llist_eq [simp]: "tllist_of_llist b' xs = TNil b \<longleftrightarrow> b = b' \<and> xs = LNil"
by(cases xs) auto

lemma TNil_eq_tllist_of_llist [simp]: "TNil b = tllist_of_llist b' xs \<longleftrightarrow> b = b' \<and> xs = LNil"
by(cases xs) auto

lemma tllist_of_llist_inject [simp]:
  "tllist_of_llist b xs = tllist_of_llist c ys \<longleftrightarrow> xs = ys \<and> (lfinite ys \<longrightarrow> b = c)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof(intro iffI conjI impI)
  assume ?rhs
  thus ?lhs by(auto intro: tllist_of_llist_cong)
next
  assume ?lhs
  thus "xs = ys"
    by(coinduction arbitrary: xs ys)(auto simp add: lnull_def neq_LNil_conv)
  assume "lfinite ys"
  thus "b = c" using `?lhs`
    unfolding `xs = ys` by(induct) simp_all
qed

lemma tllist_of_llist_inverse [simp]:
  "llist_of_tllist (tllist_of_llist b xs) = xs"
by(coinduction arbitrary: xs) auto

definition cr_tllist :: "('a llist \<times> 'b) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> bool"
  where "cr_tllist \<equiv> (\<lambda>(xs, b) ys. tllist_of_llist b xs = ys)"

lemma Quotient_tllist:
  "Quotient (\<lambda>(xs, a) (ys, b). xs = ys \<and> (lfinite ys \<longrightarrow> a = b))
     (\<lambda>(xs, a). tllist_of_llist a xs) (\<lambda>ys. (llist_of_tllist ys, terminal ys)) cr_tllist"
unfolding Quotient_alt_def cr_tllist_def by(auto intro: tllist_of_llist_cong)

lemma reflp_tllist: "reflp (\<lambda>(xs, a) (ys, b). xs = ys \<and> (lfinite ys \<longrightarrow> a = b))"
by(simp add: reflp_def)

setup_lifting Quotient_tllist reflp_tllist

context includes lifting_syntax
begin

lemma TNil_transfer [transfer_rule]:
  "(B ===> pcr_tllist A B) (Pair LNil) TNil"
by(force simp add: pcr_tllist_def cr_tllist_def)

lemma TCons_transfer [transfer_rule]:
  "(A ===> pcr_tllist A B ===> pcr_tllist A B) (apfst \<circ> LCons) TCons"
by(force simp add: pcr_tllist_def llist_all2_LCons1 cr_tllist_def)

lemma tmap_tllist_of_llist:
  "tmap f g (tllist_of_llist b xs) = tllist_of_llist (g b) (lmap f xs)"
by(coinduction arbitrary: xs)(auto simp add: tmap_is_TNil)

lemma tmap_transfer [transfer_rule]:
  "(op = ===> op = ===> pcr_tllist op = op = ===> pcr_tllist op = op =) (map_prod \<circ> lmap) tmap"
by(force simp add: cr_tllist_def tllist.pcr_cr_eq tmap_tllist_of_llist)

lemma lset_llist_of_tllist [simp]:
  "lset (llist_of_tllist xs) = tset xs" (is "?lhs = ?rhs")
proof(intro set_eqI iffI)
  fix x
  assume "x \<in> ?lhs"
  thus "x \<in> ?rhs"
    by(induct "llist_of_tllist xs" arbitrary: xs rule: llist_set_induct)(auto simp: tllist.set_sel(2))
next
  fix x
  assume "x \<in> ?rhs"
  thus "x \<in> ?lhs"
  proof(induct rule: tllist_set_induct)
    case (find xs)
    thus ?case by(cases xs) auto
  next
    case step
    thus ?case
      by(auto simp add: ltl_llist_of_tllist[symmetric] simp del: ltl_llist_of_tllist dest: in_lset_ltlD)
  qed
qed

lemma tset_tllist_of_llist [simp]:
  "tset (tllist_of_llist b xs) = lset xs"
by(simp add: lset_llist_of_tllist[symmetric] del: lset_llist_of_tllist)

lemma tset_transfer [transfer_rule]:
  "(pcr_tllist op = op = ===> op =) (lset \<circ> fst) tset"
by(auto simp add: cr_tllist_def tllist.pcr_cr_eq)

lemma is_TNil_transfer [transfer_rule]:
  "(pcr_tllist op = op = ===> op =) (\<lambda>(xs, b). lnull xs) is_TNil"
by(auto simp add: tllist.pcr_cr_eq cr_tllist_def)

lemma thd_transfer [transfer_rule]:
  "(pcr_tllist op = op = ===> op =) (lhd \<circ> fst) thd"
by(auto simp add: cr_tllist_def tllist.pcr_cr_eq)

lemma ttl_transfer [transfer_rule]:
  "(pcr_tllist A B ===> pcr_tllist A B) (apfst ltl) ttl"
by(force simp add: pcr_tllist_def cr_tllist_def intro: llist_all2_ltlI)

lemma llist_of_tllist_transfer [transfer_rule]:
  "(pcr_tllist op = B ===> op =) fst llist_of_tllist"
by(auto simp add: pcr_tllist_def cr_tllist_def llist.rel_eq)

lemma tllist_of_llist_transfer [transfer_rule]:
  "(op = ===> op = ===> pcr_tllist op = op =) (\<lambda>b xs. (xs, b)) tllist_of_llist"
by(auto simp add: tllist.pcr_cr_eq cr_tllist_def)

lemma terminal_tllist_of_llist_lfinite [simp]:
  "lfinite xs \<Longrightarrow> terminal (tllist_of_llist b xs) = b"
by(induct rule: lfinite.induct) simp_all

lemma set2_tllist_tllist_of_llist [simp]:
  "set2_tllist (tllist_of_llist b xs) = (if lfinite xs then {b} else {})"
proof(cases "lfinite xs")
  case True
  thus ?thesis by(induct) auto
next
  case False
  { fix x
    assume "x \<in> set2_tllist (tllist_of_llist b xs)"
    hence False using False
      by(induct "tllist_of_llist b xs" arbitrary: xs rule: set2_tllist_induct) fastforce+ }
  thus ?thesis using False by auto
qed

lemma set2_tllist_transfer [transfer_rule]:
  "(pcr_tllist A B ===> rel_set B) (\<lambda>(xs, b). if lfinite xs then {b} else {}) set2_tllist"
by(auto 4 4 simp add: pcr_tllist_def cr_tllist_def dest: llist_all2_lfiniteD intro: rel_setI)

lemma tllist_all2_transfer [transfer_rule]:
  "(op = ===> op = ===> pcr_tllist op = op = ===> pcr_tllist op = op = ===> op =)
     (\<lambda>P Q (xs, b) (ys, b'). llist_all2 P xs ys \<and> (lfinite xs \<longrightarrow> Q b b')) tllist_all2"
unfolding tllist.pcr_cr_eq
apply(rule rel_funI)+
apply(clarsimp simp add: cr_tllist_def llist_all2_def tllist_all2_def)
apply(safe elim!: GrpE)
   apply simp_all
   apply(rule_tac b="tllist_of_llist (b, ba) bb" in relcomppI)
    apply(auto intro!: GrpI simp add: tmap_tllist_of_llist)[2]
  apply(rule_tac b="tllist_of_llist (b, ba) bb" in relcomppI)
   apply(auto simp add: tmap_tllist_of_llist intro!: GrpI split: if_split_asm)[2]
 apply(rule_tac b="llist_of_tllist bb" in relcomppI)
apply(auto intro!: GrpI)
apply(transfer, auto intro: GrpI split: if_split_asm)+
done

subsection {* Library function definitions *}

text {*
  We lift the constants from @{typ "'a llist"} to @{typ "('a, 'b) tllist"} using the lifting package.
  This way, many results are transferred easily.
*}

lift_definition tappend :: "('a, 'b) tllist \<Rightarrow> ('b \<Rightarrow> ('a, 'c) tllist) \<Rightarrow> ('a, 'c) tllist"
is "\<lambda>(xs, b) f. apfst (lappend xs) (f b)"
by(auto simp add: split_def lappend_inf)

lift_definition lappendt :: "'a llist \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "apfst \<circ> lappend"
by(simp add: split_def)

lift_definition tfilter :: "'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>b P (xs, b'). (lfilter P xs, if lfinite xs then b' else b)"
by(simp add: split_beta)

lift_definition tconcat :: "'b \<Rightarrow> ('a llist, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>b (xss, b'). (lconcat xss, if lfinite xss then b' else b)"
by(simp add: split_beta)

lift_definition tnth :: "('a, 'b) tllist \<Rightarrow> nat \<Rightarrow> 'a"
is "lnth \<circ> fst" by(auto)

lift_definition tlength :: "('a, 'b) tllist \<Rightarrow> enat"
is "llength \<circ> fst" by auto

lift_definition tdropn :: "nat \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "apfst \<circ> ldropn" by auto

abbreviation tfinite :: "('a, 'b) tllist \<Rightarrow> bool"
where "tfinite xs \<equiv> lfinite (llist_of_tllist xs)"

subsection {* @{term "tfinite"} *}

lemma tfinite_induct [consumes 1, case_names TNil TCons]:
  assumes "tfinite xs"
  and "\<And>y. P (TNil y)"
  and "\<And>x xs. \<lbrakk>tfinite xs; P xs\<rbrakk> \<Longrightarrow> P (TCons x xs)"
  shows "P xs"
using assms
by transfer (clarsimp, erule lfinite.induct)

lemma is_TNil_tfinite [simp]: "is_TNil xs \<Longrightarrow> tfinite xs"
by transfer clarsimp

subsection {* The terminal element @{term "terminal"} *}

lemma terminal_tinfinite:
  assumes "\<not> tfinite xs"
  shows "terminal xs = undefined"
unfolding terminal0_terminal[symmetric]
using assms
apply(rule contrapos_np)
by(induct xs rule: terminal0.raw_induct[rotated 1, OF refl, consumes 1])(auto split: tllist.split_asm)

lemma terminal_tllist_of_llist:
  "terminal (tllist_of_llist y xs) = (if lfinite xs then y else undefined)"
by(simp add: terminal_tinfinite)

lemma terminal_transfer [transfer_rule]:
  "(pcr_tllist A op = ===> op =) (\<lambda>(xs, b). if lfinite xs then b else undefined) terminal"
by(force simp add: cr_tllist_def pcr_tllist_def terminal_tllist_of_llist dest: llist_all2_lfiniteD)

lemma terminal_tmap [simp]: "tfinite xs \<Longrightarrow> terminal (tmap f g xs) = g (terminal xs)"
by(induct rule: tfinite_induct) simp_all

subsection {* @{term "tmap"} *}

lemma TCons_eq_tmap_conv:
  "TCons y ys = tmap f g xs \<longleftrightarrow>
  (\<exists>z zs. xs = TCons z zs \<and> f z = y \<and> tmap f g zs = ys)"
by(cases xs) auto

subsection {* Appending two terminated lazy lists @{term "tappend" } *}

lemma tappend_TNil [simp, code, nitpick_simp]:
  "tappend (TNil b) f = f b"
by transfer auto

lemma tappend_TCons [simp, code, nitpick_simp]:
  "tappend (TCons a tr) f = TCons a (tappend tr f)"
by transfer(auto simp add: apfst_def map_prod_def split: prod.splits)

lemma tappend_TNil2 [simp]:
  "tappend xs TNil = xs"
by transfer auto

lemma tappend_assoc: "tappend (tappend xs f) g = tappend xs (\<lambda>b. tappend (f b) g)"
by transfer(auto simp add: split_beta lappend_assoc)

lemma tfinite_tappend: "tfinite (tappend xs f) \<longleftrightarrow> tfinite xs \<and> tfinite (f (terminal xs))"
by transfer auto

lift_definition tcast :: "('a, 'b) tllist \<Rightarrow> ('a, 'c) tllist"
is "\<lambda>(xs, a). (xs, undefined)" by clarsimp

lemma tappend_inf: "\<not> tfinite xs \<Longrightarrow> tappend xs f = tcast xs"
by(transfer)(auto simp add: apfst_def map_prod_def split_beta lappend_inf)

text {* @{term tappend} is the monadic bind on @{typ "('a, 'b) tllist"} *}

lemmas tllist_monad = tappend_TNil tappend_TNil2 tappend_assoc

subsection {* Appending a terminated lazy list to a lazy list @{term "lappendt"} *}

lemma lappendt_LNil [simp, code, nitpick_simp]: "lappendt LNil tr = tr"
by transfer auto

lemma lappendt_LCons [simp, code, nitpick_simp]:
  "lappendt (LCons x xs) tr = TCons x (lappendt xs tr)"
by transfer auto

lemma terminal_lappendt_lfinite [simp]:
  "lfinite xs \<Longrightarrow> terminal (lappendt xs ys) = terminal ys"
by transfer auto

lemma tllist_of_llist_eq_lappendt_conv:
  "tllist_of_llist a xs = lappendt ys zs \<longleftrightarrow>
  (\<exists>xs' a'. xs = lappend ys xs' \<and> zs = tllist_of_llist a' xs' \<and> (lfinite ys \<longrightarrow> a = a'))"
by transfer auto

lemma tset_lappendt_lfinite [simp]:
  "lfinite xs \<Longrightarrow> tset (lappendt xs ys) = lset xs \<union> tset ys"
by transfer auto

subsection {* Filtering terminated lazy lists @{term tfilter} *}

lemma tfilter_TNil [simp]:
  "tfilter b' P (TNil b) = TNil b"
by transfer auto

lemma tfilter_TCons [simp]:
  "tfilter b P (TCons a tr) = (if P a then TCons a (tfilter b P tr) else tfilter b P tr)"
by transfer auto

lemma is_TNil_tfilter[simp]:
  "is_TNil (tfilter y P xs) \<longleftrightarrow> (\<forall>x \<in> tset xs. \<not> P x)"
by transfer auto

lemma tfilter_empty_conv:
  "tfilter y P xs = TNil y' \<longleftrightarrow> (\<forall>x \<in> tset xs. \<not> P x) \<and> (if tfinite xs then terminal xs = y' else y = y')"
by transfer(clarsimp simp add: lfilter_eq_LNil)

lemma tfilter_eq_TConsD:
  "tfilter a P ys = TCons x xs \<Longrightarrow>
   \<exists>us vs. ys = lappendt us (TCons x vs) \<and> lfinite us \<and> (\<forall>u\<in>lset us. \<not> P u) \<and> P x \<and> xs = tfilter a P vs"
by transfer(fastforce dest: lfilter_eq_LConsD[OF sym])

text {* Use a version of @{term "tfilter"} for code generation that does not evaluate the first argument *}

definition tfilter' :: "(unit \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where [simp, code del]: "tfilter' b = tfilter (b ())"

lemma tfilter_code [code, code_unfold]:
  "tfilter = (\<lambda>b. tfilter' (\<lambda>_. b))"
by simp

lemma tfilter'_code [code]:
  "tfilter' b' P (TNil b) = TNil b"
  "tfilter' b' P (TCons a tr) = (if P a then TCons a (tfilter' b' P tr) else tfilter' b' P tr)"
by simp_all

end

hide_const (open) tfilter'

subsection {* Concatenating a terminated lazy list of lazy lists @{term tconcat} *}

lemma tconcat_TNil [simp]: "tconcat b (TNil b') = TNil b'"
by transfer auto

lemma tconcat_TCons [simp]: "tconcat b (TCons a tr) = lappendt a (tconcat b tr)"
by transfer auto

text {* Use a version of @{term "tconcat"} for code generation that does not evaluate the first argument *}

definition tconcat' :: "(unit \<Rightarrow> 'b) \<Rightarrow> ('a llist, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where [simp, code del]: "tconcat' b = tconcat (b ())"

lemma tconcat_code [code, code_unfold]: "tconcat = (\<lambda>b. tconcat' (\<lambda>_. b))"
by simp

lemma tconcat'_code [code]:
  "tconcat' b (TNil b') = TNil b'"
  "tconcat' b (TCons a tr) = lappendt a (tconcat' b tr)"
by simp_all

hide_const (open) tconcat'

subsection {* @{term tllist_all2} *}

lemmas tllist_all2_TNil = tllist.rel_inject(1)
lemmas tllist_all2_TCons = tllist.rel_inject(2)

lemma tllist_all2_TNil1: "tllist_all2 P Q (TNil b) ts \<longleftrightarrow> (\<exists>b'. ts = TNil b' \<and> Q b b')"
by transfer auto

lemma tllist_all2_TNil2: "tllist_all2 P Q ts (TNil b') \<longleftrightarrow> (\<exists>b. ts = TNil b \<and> Q b b')"
by transfer auto

lemma tllist_all2_TCons1:
  "tllist_all2 P Q (TCons x ts) ts' \<longleftrightarrow> (\<exists>x' ts''. ts' = TCons x' ts'' \<and> P x x' \<and> tllist_all2 P Q ts ts'')"
by transfer(fastforce simp add: llist_all2_LCons1 dest: llist_all2_lfiniteD)

lemma tllist_all2_TCons2:
  "tllist_all2 P Q ts' (TCons x ts) \<longleftrightarrow> (\<exists>x' ts''. ts' = TCons x' ts'' \<and> P x' x \<and> tllist_all2 P Q ts'' ts)"
by transfer(fastforce simp add: llist_all2_LCons2 dest: llist_all2_lfiniteD)

lemma tllist_all2_coinduct [consumes 1, case_names tllist_all2, case_conclusion tllist_all2 is_TNil TNil TCons, coinduct pred: tllist_all2]:
  assumes "X xs ys"
  and "\<And>xs ys. X xs ys \<Longrightarrow>
  (is_TNil xs \<longleftrightarrow> is_TNil ys) \<and>
  (is_TNil xs \<longrightarrow> is_TNil ys \<longrightarrow> R (terminal xs) (terminal ys)) \<and>
  (\<not> is_TNil xs \<longrightarrow> \<not> is_TNil ys \<longrightarrow> P (thd xs) (thd ys) \<and> (X (ttl xs) (ttl ys) \<or> tllist_all2 P R (ttl xs) (ttl ys)))"
  shows "tllist_all2 P R xs ys"
using assms
apply(transfer fixing: P R)
apply clarsimp
apply(rule conjI)
 apply(erule llist_all2_coinduct, blast, blast)
apply (rule impI)
subgoal premises prems for X xs b ys c
proof -
  from `lfinite xs` `X (xs, b) (ys, c)`
  show "R b c"
    by(induct arbitrary: ys rule: lfinite_induct)(auto dest: prems(2))
qed
done

lemma tllist_all2_cases[consumes 1, case_names TNil TCons, cases pred]:
  assumes "tllist_all2 P Q xs ys"
  obtains (TNil) b b' where "xs = TNil b" "ys = TNil b'" "Q b b'"
  | (TCons) x xs' y ys'
    where "xs = TCons x xs'" and "ys = TCons y ys'"
    and "P x y" and "tllist_all2 P Q xs' ys'"
using assms
by(cases xs)(fastforce simp add: tllist_all2_TCons1 tllist_all2_TNil1)+

lemma tllist_all2_tmap1:
  "tllist_all2 P Q (tmap f g xs) ys \<longleftrightarrow> tllist_all2 (\<lambda>x. P (f x)) (\<lambda>x. Q (g x)) xs ys"
by(transfer)(auto simp add: llist_all2_lmap1)

lemma tllist_all2_tmap2:
  "tllist_all2 P Q xs (tmap f g ys) \<longleftrightarrow> tllist_all2 (\<lambda>x y. P x (f y)) (\<lambda>x y. Q x (g y)) xs ys"
by(transfer)(auto simp add: llist_all2_lmap2)

lemma tllist_all2_mono:
  "\<lbrakk> tllist_all2 P Q xs ys; \<And>x y. P x y \<Longrightarrow> P' x y; \<And>x y. Q x y \<Longrightarrow> Q' x y \<rbrakk>
  \<Longrightarrow> tllist_all2 P' Q' xs ys"
by transfer(auto elim!: llist_all2_mono)

lemma tllist_all2_tlengthD: "tllist_all2 P Q xs ys \<Longrightarrow> tlength xs = tlength ys"
by(transfer)(auto dest: llist_all2_llengthD)

lemma tllist_all2_tfiniteD: "tllist_all2 P Q xs ys \<Longrightarrow> tfinite xs = tfinite ys"
by(transfer)(auto dest: llist_all2_lfiniteD)

lemma tllist_all2_tfinite1_terminalD:
  "\<lbrakk> tllist_all2 P Q xs ys; tfinite xs \<rbrakk> \<Longrightarrow> Q (terminal xs) (terminal ys)"
by(frule tllist_all2_tfiniteD)(transfer, auto)

lemma tllist_all2_tfinite2_terminalD:
  "\<lbrakk> tllist_all2 P Q xs ys; tfinite ys \<rbrakk> \<Longrightarrow> Q (terminal xs) (terminal ys)"
by(metis tllist_all2_tfinite1_terminalD tllist_all2_tfiniteD)

lemma tllist_all2D_llist_all2_llist_of_tllist:
  "tllist_all2 P Q xs ys \<Longrightarrow> llist_all2 P (llist_of_tllist xs) (llist_of_tllist ys)"
by(transfer) auto

lemma tllist_all2_is_TNilD:
  "tllist_all2 P Q xs ys \<Longrightarrow> is_TNil xs \<longleftrightarrow> is_TNil ys"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_thdD:
  "\<lbrakk> tllist_all2 P Q xs ys; \<not> is_TNil xs \<or> \<not> is_TNil ys \<rbrakk> \<Longrightarrow> P (thd xs) (thd ys)"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_ttlI:
  "\<lbrakk> tllist_all2 P Q xs ys; \<not> is_TNil xs \<or> \<not> is_TNil ys \<rbrakk> \<Longrightarrow> tllist_all2 P Q (ttl xs) (ttl ys)"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_refl:
  "tllist_all2 P Q xs xs \<longleftrightarrow> (\<forall>x \<in> tset xs. P x x) \<and> (tfinite xs \<longrightarrow> Q (terminal xs) (terminal xs))"
by transfer(auto)

lemma tllist_all2_reflI:
  "\<lbrakk> \<And>x. x \<in> tset xs \<Longrightarrow> P x x; tfinite xs \<Longrightarrow> Q (terminal xs) (terminal xs) \<rbrakk>
  \<Longrightarrow> tllist_all2 P Q xs xs"
by(simp add: tllist_all2_refl)

lemma tllist_all2_conv_all_tnth:
  "tllist_all2 P Q xs ys \<longleftrightarrow>
  tlength xs = tlength ys \<and>
  (\<forall>n. enat n < tlength xs \<longrightarrow> P (tnth xs n) (tnth ys n)) \<and>
  (tfinite xs \<longrightarrow> Q (terminal xs) (terminal ys))"
by transfer(auto 4 4 simp add: llist_all2_conv_all_lnth split: if_split_asm dest: lfinite_llength_enat not_lfinite_llength)

lemma tllist_all2_tnthD:
  "\<lbrakk> tllist_all2 P Q xs ys; enat n < tlength xs \<rbrakk>
  \<Longrightarrow> P (tnth xs n) (tnth ys n)"
by(simp add: tllist_all2_conv_all_tnth)

lemma tllist_all2_tnthD2:
  "\<lbrakk> tllist_all2 P Q xs ys; enat n < tlength ys \<rbrakk>
  \<Longrightarrow> P (tnth xs n) (tnth ys n)"
by(simp add: tllist_all2_conv_all_tnth)

lemmas tllist_all2_eq = tllist.rel_eq

lemma tmap_eq_tmap_conv_tllist_all2:
  "tmap f g xs = tmap f' g' ys \<longleftrightarrow>
  tllist_all2 (\<lambda>x y. f x = f' y) (\<lambda>x y. g x = g' y) xs ys"
apply transfer
apply(clarsimp simp add: lmap_eq_lmap_conv_llist_all2)
apply(auto dest: llist_all2_lfiniteD)
done

lemma tllist_all2_trans:
  "\<lbrakk> tllist_all2 P Q xs ys; tllist_all2 P Q ys zs; transp P; transp Q \<rbrakk>
  \<Longrightarrow> tllist_all2 P Q xs zs"
by transfer(auto elim: llist_all2_trans dest: llist_all2_lfiniteD transpD)

lemma tllist_all2_tappendI:
  "\<lbrakk> tllist_all2 P Q xs ys;
     \<lbrakk> tfinite xs; tfinite ys; Q (terminal xs) (terminal ys) \<rbrakk>
     \<Longrightarrow> tllist_all2 P R (xs' (terminal xs)) (ys' (terminal ys)) \<rbrakk>
  \<Longrightarrow> tllist_all2 P R (tappend xs xs') (tappend ys ys')"
apply transfer
apply(auto 4 3 simp add: apfst_def map_prod_def lappend_inf split: prod.split_asm dest: llist_all2_lfiniteD intro: llist_all2_lappendI)
apply(frule llist_all2_lfiniteD, simp add: lappend_inf)
done

lemma llist_all2_tllist_of_llistI:
  "tllist_all2 A B xs ys \<Longrightarrow> llist_all2 A (llist_of_tllist xs) (llist_of_tllist ys)"
by(coinduction arbitrary: xs ys)(auto dest: tllist_all2_is_TNilD tllist_all2_thdD intro: tllist_all2_ttlI)

lemma tllist_all2_tllist_of_llist [simp]:
  "tllist_all2 A B (tllist_of_llist b xs) (tllist_of_llist c ys) \<longleftrightarrow>
  llist_all2 A xs ys \<and> (lfinite xs \<longrightarrow> B b c)"
by transfer auto

subsection {* From a terminated lazy list to a lazy list @{term llist_of_tllist} *}

lemma llist_of_tllist_tmap [simp]:
  "llist_of_tllist (tmap f g xs) = lmap f (llist_of_tllist xs)"
by transfer auto

lemma llist_of_tllist_tappend:
  "llist_of_tllist (tappend xs f) = lappend (llist_of_tllist xs) (llist_of_tllist (f (terminal xs)))"
by(transfer)(auto simp add: lappend_inf)

lemma llist_of_tllist_lappendt [simp]:
  "llist_of_tllist (lappendt xs tr) = lappend xs (llist_of_tllist tr)"
by transfer auto

lemma llist_of_tllist_tfilter [simp]:
  "llist_of_tllist (tfilter b P tr) = lfilter P (llist_of_tllist tr)"
by transfer auto

lemma llist_of_tllist_tconcat:
  "llist_of_tllist (tconcat b trs) = lconcat (llist_of_tllist trs)"
by transfer auto

lemma llist_of_tllist_eq_lappend_conv:
  "llist_of_tllist xs = lappend us vs \<longleftrightarrow>
  (\<exists>ys. xs = lappendt us ys \<and> vs = llist_of_tllist ys \<and> terminal xs = terminal ys)"
by transfer auto

subsection {* The nth element of a terminated lazy list @{term "tnth"} *}

lemma tnth_TNil [nitpick_simp]:
  "tnth (TNil b) n = undefined n"
by(transfer)(simp add: lnth_LNil)

lemma tnth_TCons:
  "tnth (TCons x xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> tnth xs n')"
by(transfer)(auto simp add: lnth_LCons split: nat.split)

lemma lnth_llist_of_tllist [simp]:
  "lnth (llist_of_tllist xs) = tnth xs"
by(transfer)(auto)

lemma tnth_tmap [simp]: "enat n < tlength xs \<Longrightarrow> tnth (tmap f g xs) n = f (tnth xs n)"
by transfer simp

subsection {* The length of a terminated lazy list @{term "tlength"} *}

lemma [simp, nitpick_simp]:
  shows tlength_TNil: "tlength (TNil b) = 0"
  and tlength_TCons: "tlength (TCons x xs) = eSuc (tlength xs)"
 apply(transfer, simp)
apply(transfer, auto)
done

lemma llength_llist_of_tllist [simp]: "llength (llist_of_tllist xs) = tlength xs"
by transfer auto

lemma tlength_tmap [simp]: "tlength (tmap f g xs) = tlength xs"
by transfer simp

definition gen_tlength :: "nat \<Rightarrow> ('a, 'b) tllist \<Rightarrow> enat"
where "gen_tlength n xs = enat n + tlength xs"

lemma gen_tlength_code [code]:
  "gen_tlength n (TNil b) = enat n"
  "gen_tlength n (TCons x xs) = gen_tlength (n + 1) xs"
by(simp_all add: gen_tlength_def iadd_Suc eSuc_enat[symmetric] iadd_Suc_right)

lemma tlength_code [code]: "tlength = gen_tlength 0"
by(simp add: gen_tlength_def fun_eq_iff zero_enat_def)

subsection {* @{term "tdropn"} *}

lemma tdropn_0 [simp, code, nitpick_simp]: "tdropn 0 xs = xs"
by transfer auto

lemma tdropn_TNil [simp, code]: "tdropn n (TNil b) = (TNil b)"
by transfer(auto)

lemma tdropn_Suc_TCons [simp, code]: "tdropn (Suc n) (TCons x xs) = tdropn n xs"
by transfer(auto)

lemma tdropn_Suc [nitpick_simp]: "tdropn (Suc n) xs = (case xs of TNil b \<Rightarrow> TNil b | TCons x xs' \<Rightarrow> tdropn n xs')"
by(cases xs) simp_all

lemma lappendt_ltake_tdropn:
  "lappendt (ltake (enat n) (llist_of_tllist xs)) (tdropn n xs) = xs"
by transfer (auto)

lemma llist_of_tllist_tdropn [simp]:
  "llist_of_tllist (tdropn n xs) = ldropn n (llist_of_tllist xs)"
by transfer auto

lemma tdropn_Suc_conv_tdropn:
  "enat n < tlength xs \<Longrightarrow> TCons (tnth xs n) (tdropn (Suc n) xs) = tdropn n xs"
by transfer(auto simp add: ldropn_Suc_conv_ldropn)

lemma tlength_tdropn [simp]: "tlength (tdropn n xs) = tlength xs - enat n"
by transfer auto

lemma tnth_tdropn [simp]: "enat (n + m) < tlength xs \<Longrightarrow> tnth (tdropn n xs) m = tnth xs (m + n)"
by transfer auto

subsection {* @{term "tset"} *}

lemma tset_induct [consumes 1, case_names find step]:
  assumes "x \<in> tset xs"
  and "\<And>xs. P (TCons x xs)"
  and "\<And>x' xs. \<lbrakk> x \<in> tset xs; x \<noteq> x'; P xs \<rbrakk> \<Longrightarrow> P (TCons x' xs)"
  shows "P xs"
using assms
by transfer(clarsimp, erule lset_induct)

lemma tset_conv_tnth: "tset xs = {tnth xs n|n . enat n < tlength xs}"
by transfer(simp add: lset_conv_lnth)

lemma in_tset_conv_tnth: "x \<in> tset xs \<longleftrightarrow> (\<exists>n. enat n < tlength xs \<and> tnth xs n = x)"
using tset_conv_tnth[of xs] by auto

subsection {* Setup for Lifting/Transfer *}

subsubsection {* Relator and predicator properties *}

abbreviation "tllist_all == pred_tllist"

subsubsection {* Transfer rules for the Transfer package *}

context includes lifting_syntax
begin

lemma set1_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set A) set1_pre_tllist set1_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set1_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma set2_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set B) set2_pre_tllist set2_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set2_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma set3_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set C) set3_pre_tllist set3_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set3_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma TNil_transfer2 [transfer_rule]: "(B ===> tllist_all2 A B) TNil TNil"
by auto
declare TNil_transfer [transfer_rule]

lemma TCons_transfer2 [transfer_rule]:
  "(A ===> tllist_all2 A B ===> tllist_all2 A B) TCons TCons"
unfolding rel_fun_def by simp
declare TCons_transfer [transfer_rule]

lemma case_tllist_transfer [transfer_rule]:
  "((B ===> C) ===> (A ===> tllist_all2 A B ===> C) ===> tllist_all2 A B ===> C)
    case_tllist case_tllist"
unfolding rel_fun_def
by (simp add: tllist_all2_TNil1 tllist_all2_TNil2 split: tllist.split)

lemma unfold_tllist_transfer [transfer_rule]:
  "((A ===> op =) ===> (A ===> B) ===> (A ===> C) ===> (A ===> A) ===> A ===> tllist_all2 C B) unfold_tllist unfold_tllist"
proof(rule rel_funI)+
  fix IS_TNIL1 :: "'a \<Rightarrow> bool" and IS_TNIL2
    TERMINAL1 TERMINAL2 THD1 THD2 TTL1 TTL2 x y
  assume rel: "(A ===> op =) IS_TNIL1 IS_TNIL2" "(A ===> B) TERMINAL1 TERMINAL2"
    "(A ===> C) THD1 THD2" "(A ===> A) TTL1 TTL2"
    and "A x y"
  show "tllist_all2 C B (unfold_tllist IS_TNIL1 TERMINAL1 THD1 TTL1 x) (unfold_tllist IS_TNIL2 TERMINAL2 THD2 TTL2 y)"
    using `A x y`
    apply(coinduction arbitrary: x y)
    using rel by(auto 4 4 elim: rel_funE)
qed

lemma corec_tllist_transfer [transfer_rule]:
  "((A ===> op =) ===> (A ===> B) ===> (A ===> C) ===> (A ===> op =) ===> (A ===> tllist_all2 C B) ===> (A ===> A) ===> A ===> tllist_all2 C B) corec_tllist corec_tllist"
proof(rule rel_funI)+
  fix IS_TNIL1 MORE1 :: "'a \<Rightarrow> bool" and IS_TNIL2
    TERMINAL1 TERMINAL2 THD1 THD2 MORE2 STOP1 STOP2 TTL1 TTL2 x y
  assume rel: "(A ===> op =) IS_TNIL1 IS_TNIL2" "(A ===> B) TERMINAL1 TERMINAL2"
    "(A ===> C) THD1 THD2" "(A ===> op =) MORE1 MORE2"
    "(A ===> tllist_all2 C B) STOP1 STOP2" "(A ===> A) TTL1 TTL2"
    and "A x y"
  show "tllist_all2 C B (corec_tllist IS_TNIL1 TERMINAL1 THD1 MORE1 STOP1 TTL1 x) (corec_tllist IS_TNIL2 TERMINAL2 THD2 MORE2 STOP2 TTL2 y)"
    using `A x y`
    apply(coinduction arbitrary: x y)
    using rel by(auto 4 4 elim: rel_funE)
qed

lemma ttl_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> tllist_all2 A B) ttl ttl"
  unfolding ttl_def[abs_def] by transfer_prover
declare ttl_transfer [transfer_rule]

lemma tset_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> rel_set A) tset tset"
by (intro rel_funI rel_setI) (auto simp only: in_tset_conv_tnth tllist_all2_conv_all_tnth Bex_def)

lemma tmap_transfer2 [transfer_rule]:
  "((A ===> B) ===> (C ===> D) ===> tllist_all2 A C ===> tllist_all2 B D) tmap tmap"
by(auto simp add: rel_fun_def tllist_all2_tmap1 tllist_all2_tmap2 elim: tllist_all2_mono)
declare tmap_transfer [transfer_rule]

lemma is_TNil_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> op =) is_TNil is_TNil"
by(auto dest: tllist_all2_is_TNilD)
declare is_TNil_transfer [transfer_rule]

lemma tappend_transfer [transfer_rule]:
  "(tllist_all2 A B ===> (B ===> tllist_all2 A C) ===> tllist_all2 A C) tappend tappend"
by(auto intro: tllist_all2_tappendI elim: rel_funE)
declare tappend.transfer [transfer_rule]

lemma lappendt_transfer [transfer_rule]:
  "(llist_all2 A ===> tllist_all2 A B ===> tllist_all2 A B) lappendt lappendt"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lappendI)
declare lappendt.transfer [transfer_rule]

lemma llist_of_tllist_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> llist_all2 A) llist_of_tllist llist_of_tllist"
by(auto intro: llist_all2_tllist_of_llistI)
declare llist_of_tllist_transfer [transfer_rule]

lemma tllist_of_llist_transfer2 [transfer_rule]:
  "(B ===> llist_all2 A ===> tllist_all2 A B) tllist_of_llist tllist_of_llist"
by(auto intro!: rel_funI)
declare tllist_of_llist_transfer [transfer_rule]

lemma tlength_transfer [transfer_rule]:
  "(tllist_all2 A B ===> op =) tlength tlength"
by(auto dest: tllist_all2_tlengthD)
declare tlength.transfer [transfer_rule]

lemma tdropn_transfer [transfer_rule]:
  "(op = ===> tllist_all2 A B ===> tllist_all2 A B) tdropn tdropn"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_ldropnI)
declare tdropn.transfer [transfer_rule]

lemma tfilter_transfer [transfer_rule]:
  "(B ===> (A ===> op =) ===> tllist_all2 A B ===> tllist_all2 A B) tfilter tfilter"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lfilterI dest: llist_all2_lfiniteD)
declare tfilter.transfer [transfer_rule]

lemma tconcat_transfer [transfer_rule]:
  "(B ===> tllist_all2 (llist_all2 A) B ===> tllist_all2 A B) tconcat tconcat"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lconcatI dest: llist_all2_lfiniteD)
declare tconcat.transfer [transfer_rule]

lemma tllist_all2_rsp:
  assumes R1: "\<forall>x y. R1 x y \<longrightarrow> (\<forall>a b. R1 a b \<longrightarrow> S x a = T y b)"
  and R2: "\<forall>x y. R2 x y \<longrightarrow> (\<forall>a b. R2 a b \<longrightarrow> S' x a = T' y b)"
  and xsys: "tllist_all2 R1 R2 xs ys"
  and xs'ys': "tllist_all2 R1 R2 xs' ys'"
  shows "tllist_all2 S S' xs xs' = tllist_all2 T T' ys ys'"
proof
  assume "tllist_all2 S S' xs xs'"
  with xsys xs'ys' show "tllist_all2 T T' ys ys'"
  proof(coinduction arbitrary: ys ys' xs xs')
    case (tllist_all2 ys ys' xs xs')
    thus ?case
      by cases (auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TCons2 tllist_all2_TNil1 tllist_all2_TNil2 dest: R1[rule_format] R2[rule_format])
  qed
next
  assume "tllist_all2 T T' ys ys'"
  with xsys xs'ys' show "tllist_all2 S S' xs xs'"
  proof(coinduction arbitrary: xs xs' ys ys')
    case (tllist_all2 xs xs' ys ys')
    thus ?case
      by cases(auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TCons2 tllist_all2_TNil1 tllist_all2_TNil2 dest: R1[rule_format] R2[rule_format])
  qed
qed

lemma tllist_all2_transfer2 [transfer_rule]:
  "((R1 ===> R1 ===> op =) ===> (R2 ===> R2 ===> op =) ===>
    tllist_all2 R1 R2 ===> tllist_all2 R1 R2 ===> op =) tllist_all2 tllist_all2"
by (simp add: tllist_all2_rsp rel_fun_def)
declare tllist_all2_transfer [transfer_rule]

end

text {*
  Delete lifting rules for @{typ "('a, 'b) tllist"}
  because the parametricity rules take precedence over
  most of the transfer rules. They can be restored by
  including the bundle @{text "tllist.lifting"}.
*}

lifting_update tllist.lifting
lifting_forget tllist.lifting

end


section "Big Proofs"

theory Big_Proof
imports Big_Aux Common_Proof
begin

lemma step_list [simp]: "invar big \<Longrightarrow> list (step big) = list big"
proof(induction big rule: step_state.induct)
  case 1
  then show ?case
    by auto
next
  case 2
  then show ?case
    by(auto split: current.splits)
next
  case 3
  then show ?case
    by(auto simp: rev_take take_drop drop_Suc tl_take rev_drop split: current.splits)
qed

lemma step_list_current [simp]: "invar big \<Longrightarrow> list_current (step big) = list_current big"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma push_list [simp]: "list (push x big) = x # list big"
proof(induction x big rule: push.induct)
  case (1 x state)
  then show ?case
    by auto
next
  case (2 x current big aux count)
  then show ?case
    by(induction x current rule: Current.push.induct) auto
qed

lemma list_Reverse: "\<lbrakk>
    0 < size (Reverse current big aux count);
    invar (Reverse current big aux count)
\<rbrakk> \<Longrightarrow> first current # list (Reverse (drop_first current) big aux count) =
      list (Reverse current big aux count)"
proof(induction current rule: Current.pop.induct)
  case (1 added old remained)
  then have [simp]: "remained - Suc 0 < length (take_rev count (Stack_Aux.list big) @ aux)"
    by(auto simp: le_diff_conv)

  (* TODO: *)
  then have "
   \<lbrakk>0 < size old; 0 < remained; added = 0; remained - count \<le> length aux; count \<le> size big;
     Stack_Aux.list old =
     rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack_Aux.list big)));
     take remained (rev (take (size old - size big) aux)) @
     take (remained - min (length aux) (size old - size big))
      (rev (take (size old) (rev (Stack_Aux.list big)))) =
     rev (take (remained - count) aux) @ rev (take remained (rev (take count (Stack_Aux.list big))))\<rbrakk>
    \<Longrightarrow> hd (rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack_Aux.list big)))) =
        (rev (take count (Stack_Aux.list big)) @ aux) ! (remained - Suc 0)"
    by (smt (verit) Suc_pred hd_drop_conv_nth hd_rev hd_take last_snoc length_rev length_take min.absorb2 rev_append take_rev_def size_list_length take_append take_hd_drop)

  with 1 have [simp]: "Stack.first old = (take_rev count (Stack_Aux.list big) @ aux) ! (remained - Suc 0)"
    by(auto simp: take_hd_drop first_hd)

  from 1 show ?case
    using take_rev_nth[of
          "remained - Suc 0" "take_rev count (Stack_Aux.list big) @ aux" "Stack.first old" "[]"
        ]
    by auto
next
  case 2
  then show ?case by auto
qed

lemma size_list [simp]: " \<lbrakk>0 < size big; invar big; list big = []\<rbrakk> \<Longrightarrow> False"
proof(induction big rule: list.induct)
  case 1
  then show ?case
    using list_size by auto
next
  case 2
  then show ?case
    by (metis list.distinct(1) list_Reverse)
qed

lemma pop_list [simp]: "\<lbrakk>0 < size big; invar big; Big.pop big = (x, big')\<rbrakk>
   \<Longrightarrow> x # list big' = list big"
proof(induction big arbitrary: x rule: list.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case 2
  then show ?case
    by (metis Big.pop.simps(2) list_Reverse prod.inject)
qed

lemma pop_list_tl: "\<lbrakk>0 < size big; invar big; pop big = (x, big')\<rbrakk> \<Longrightarrow> list big' = tl (list big)"
  using pop_list cons_tl[of x "list big'" "list big"]
  by force

(* TODO: *)

  then obtain extra old remained where current:
      "current = Current extra (length extra) old remained"
    by(auto split: current.splits)

  (* TODO: *)
  with 2 have "\<lbrakk>current = Current extra (length extra) old remained; remained \<le> length aux;
     Stack_Aux.list old =
     rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack_Aux.list big)));
     take remained (rev (take (size old - size big) aux)) @
     take (remained - min (length aux) (size old - size big))
      (rev (take (size old) (rev (Stack_Aux.list big)))) =
     rev (take remained aux)\<rbrakk>
    \<Longrightarrow> remained \<le> size old"
    by(metis length_rev length_take min.absorb_iff2 size_list_length take_append)

  with 2 current have "remained - size old = 0"
    by auto

  with current 2 show ?case
    by(auto simp: take_rev_drop drop_rev)
next
  case (3 current big aux count)
  then have "0 < size big"
    by(auto split: current.splits)

  then have big_not_empty:  "Stack_Aux.list big \<noteq> []"
    by(auto simp: Stack_Proof.size_not_empty  Stack_Proof.list_not_empty)

  with 3 have a: "
      rev (Stack_Aux.list big) @ aux =
      rev (Stack_Aux.list (Stack.pop big)) @ Stack.first big # aux"
    by(auto simp: rev_tl_hd first_hd split: current.splits)

  from 3 have "0 < size big"
    by(auto split: current.splits)

  from 3 big_not_empty have "
      take_rev (Suc count) (Stack_Aux.list big) @  aux =
      take_rev count (Stack_Aux.list (Stack.pop big)) @ (Stack.first big # aux)"
    using take_rev_tl_hd[of "Suc count" "Stack_Aux.list big" aux]
    by(auto simp: Stack_Proof.list_not_empty split: current.splits)

  with 3 a show ?case
    by(auto split: current.splits)
qed

lemma invar_push: "invar big \<Longrightarrow> invar (push x big)"
  by(induction x big rule: push.induct)(auto simp: invar_push split: current.splits)

(* TODO: *)
lemma invar_pop: "\<lbrakk>
  0 < size big;
  invar big;
  pop big = (x, big')
\<rbrakk> \<Longrightarrow> invar big'"
proof(induction big arbitrary: x rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: invar_pop split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    have linarith: "\<And>x y z. x - y \<le> z \<Longrightarrow> x - (Suc y) \<le> z"
      by linarith

    have a: " \<lbrakk>remained \<le> count + length aux; 0 < remained; added = 0; x = Stack.first old;
         big' = Reverse (Current [] 0 (Stack.pop old) (remained - Suc 0)) big aux count;
         count \<le> size big; Stack_Aux.list old = rev aux @ Stack_Aux.list big;
         take remained (rev aux) @ take (remained - length aux) (Stack_Aux.list big) =
         drop (count + length aux - remained) (rev aux) @
         drop (count - remained) (take count (Stack_Aux.list big));
         \<not> size old \<le> length aux + size big\<rbrakk>
        \<Longrightarrow> tl (rev aux @ Stack_Aux.list big) = rev aux @ Stack_Aux.list big"
      by (metis le_refl length_append length_rev size_list_length)

    have b: "\<lbrakk>remained \<le> length (take_rev count (Stack_Aux.list big) @ aux); 0 < size old;
          0 < remained; added = 0;
         x = Stack.first old;
         big' = Reverse (Current [] 0 (Stack.pop old) (remained - Suc 0)) big aux count;
         remained - count \<le> length aux; count \<le> size big;
         Stack_Aux.list old =
         drop (length aux - (size old - size big)) (rev aux) @
         drop (size big - size old) (Stack_Aux.list big);
         take remained (drop (length aux - (size old - size big)) (rev aux)) @
         take (remained + (length aux - (size old - size big)) - length aux)
          (drop (size big - size old) (Stack_Aux.list big)) =
         drop (length (take_rev count (Stack_Aux.list big) @ aux) - remained)
          (rev (take_rev count (Stack_Aux.list big) @ aux))\<rbrakk>
        \<Longrightarrow> tl (drop (length aux - (size old - size big)) (rev aux) @
                drop (size big - size old) (Stack_Aux.list big)) =
            drop (length aux - (size old - Suc (size big))) (rev aux) @
            drop (Suc (size big) - size old) (Stack_Aux.list big)"
      apply(cases "size old - size big \<le> length aux"; cases "size old \<le> size big")
      by(auto simp: tl_drop_2 Suc_diff_le le_diff_conv le_refl a)

    from 1 have "remained \<le> length (take_rev count (Stack_Aux.list big) @ aux)"
      by(auto)

    with 1 show ?case
      apply(auto simp: rev_take take_tl drop_Suc Suc_diff_le tl_drop linarith simp del: take_rev_def)
      using b
      apply (metis \<open>remained \<le> length (take_rev count (Stack_Aux.list big) @ aux)\<close> rev_append rev_take take_append)
      by (smt (verit, del_insts) Nat.diff_cancel tl_append_if Suc_diff_le append_self_conv2 diff_add_inverse diff_diff_cancel diff_is_0_eq diff_le_mono drop_eq_Nil2 length_rev nle_le not_less_eq_eq plus_1_eq_Suc tl_drop_2)
  next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma push_list_current [simp]: "list_current (push x big) = x # list_current big"
  by(induction x big rule: push.induct) auto

lemma pop_list_current [simp]: "\<lbrakk>invar big; 0 < size big; Big.pop big = (x, big')\<rbrakk>
   \<Longrightarrow> x # list_current big' = list_current big"
proof(induction big arbitrary: x rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: pop_list_current split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)

    then have
        "rev (take (size old - size big) aux) @ rev (take (size old) (rev (Stack_Aux.list big))) \<noteq> []"
      using
        order_less_le_trans[of 0 "size old" "size big"]
        order_less_le_trans[of 0 count "size big"]
      by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

    with 1 show ?case
      by(auto simp: first_hd)
  next
    case (2 x xs added old remained)
    then show ?case
      by auto
  qed
qed

lemma list_current_size: "\<lbrakk>0 < size big; list_current big = []; invar big\<rbrakk> \<Longrightarrow> False"
proof(induction big rule: list_current.induct)
  case 1
  then show ?case
    using list_current_size
    by simp
next
  case (2 current uu uv uw)
  then show ?case
    apply(cases current)
    by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_empty)
qed

lemma step_size: "invar (big :: 'a state) \<Longrightarrow> size big = size (step big)"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma remaining_steps_step [simp]: "\<lbrakk>invar (big :: 'a state); remaining_steps big > 0\<rbrakk>
   \<Longrightarrow> Suc (remaining_steps (step big)) = remaining_steps big"
  by(induction big rule: step_state.induct)(auto split: current.splits)

lemma remaining_steps_step_0 [simp]: "\<lbrakk>invar (big :: 'a state); remaining_steps big = 0\<rbrakk>
    \<Longrightarrow> remaining_steps (step big) = 0"
  by(induction big)(auto split: current.splits)

lemma remaining_steps_push: "invar big \<Longrightarrow> remaining_steps (push x big) = remaining_steps big"
  by(induction x big rule: push.induct)(auto split: current.splits)

lemma remaining_steps_pop: "\<lbrakk>invar big; pop big = (x, big')\<rbrakk>
   \<Longrightarrow> remaining_steps big' \<le> remaining_steps big"
proof(induction big rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: remaining_steps_pop split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_push [simp]: "invar big \<Longrightarrow> size (push x big) = Suc (size big)"
  by(induction x big rule: push.induct)(auto split: current.splits)

lemma size_new_push [simp]: "invar big \<Longrightarrow> size_new (push x big) = Suc (size_new big)"
  by(induction x big rule: Big.push.induct)(auto split: current.splits)

lemma size_pop [simp]: "\<lbrakk>invar big; 0 < size big; pop big = (x, big')\<rbrakk>
   \<Longrightarrow> Suc (size big') = size big"
proof(induction big rule: pop.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_new_pop [simp]: "\<lbrakk>invar big; 0 < size_new big; pop big = (x, big')\<rbrakk>
    \<Longrightarrow> Suc (size_new big') = size_new big"
proof(induction big rule: pop.induct)
  case 1
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current big aux count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_size_new: "\<lbrakk>invar (big :: 'a state); 0 < size big\<rbrakk> \<Longrightarrow> 0 < size_new big"
  by(induction big)(auto simp: size_size_new)

end


theory PullbackConstruction
  imports Morphism Pullback
begin

locale pullback_construction =
  f: morphism B D f +
  g: morphism C D g
  for B D C f g
begin

abbreviation V where \<open>V \<equiv> {(x,y). x \<in> V\<^bsub>B\<^esub> \<and> y \<in> V\<^bsub>C\<^esub> \<and> \<^bsub>f\<^esub>\<^sub>V x = \<^bsub>g\<^esub>\<^sub>V y}\<close>
abbreviation E where \<open>E \<equiv> {(x,y). x \<in> E\<^bsub>B\<^esub> \<and> y \<in> E\<^bsub>C\<^esub> \<and> \<^bsub>f\<^esub>\<^sub>E x = \<^bsub>g\<^esub>\<^sub>E y}\<close>
fun s where \<open>s (x,y) = (s\<^bsub>B\<^esub> x, s\<^bsub>C\<^esub> y)\<close>
fun t where \<open>t (x,y) = (t\<^bsub>B\<^esub> x, t\<^bsub>C\<^esub> y)\<close>
fun l where \<open>l (x,_) = l\<^bsub>B\<^esub> x\<close>
fun m where \<open>m (x,_) = m\<^bsub>B\<^esub> x\<close>

definition A where \<open>A \<equiv> \<lparr>nodes = V, edges = E, source = s, target = t, node_label = l, edge_label = m\<rparr>\<close>

sublocale A: graph A
proof
  show \<open>finite V\<^bsub>A\<^esub>\<close>
  proof -
    have \<open>finite (V\<^bsub>B\<^esub> \<times> V\<^bsub>C\<^esub>)\<close>
      using f.G.finite_nodes g.G.finite_nodes
      by simp
    moreover have \<open>V \<subseteq> V\<^bsub>B\<^esub> \<times> V\<^bsub>C\<^esub>\<close>
      by blast
    ultimately show ?thesis
      by (simp add: A_def finite_subset)
  qed
next
  show \<open>finite E\<^bsub>A\<^esub>\<close>
  proof -
    have \<open>finite (E\<^bsub>B\<^esub> \<times> E\<^bsub>C\<^esub>)\<close>
      using f.G.finite_edges g.G.finite_edges
      by simp
    moreover have \<open>E \<subseteq> E\<^bsub>B\<^esub> \<times> E\<^bsub>C\<^esub>\<close>
      by blast
    ultimately show ?thesis
      by (simp add: A_def finite_subset)
  qed
next
  show \<open>s\<^bsub>A\<^esub> e \<in> V\<^bsub>A\<^esub>\<close> if \<open>e \<in> E\<^bsub>A\<^esub>\<close> for e
    using that f.G.source_integrity g.G.source_integrity
    by (auto simp add: A_def f.source_preserve g.source_preserve)
next
  show \<open>t\<^bsub>A\<^esub> e \<in> V\<^bsub>A\<^esub>\<close> if \<open>e \<in> E\<^bsub>A\<^esub>\<close> for e
    using that f.G.target_integrity g.G.target_integrity
    by (auto simp add: A_def f.target_preserve g.target_preserve)
qed

definition b :: "('a \<times> 'g, 'a, 'b \<times> 'h, 'b) pre_morph" where \<open>b \<equiv> \<lparr>node_map = fst, edge_map = fst\<rparr>\<close>
sublocale b: morphism A B b
  by standard (auto simp add: A_def b_def)

definition c :: "('a \<times> 'g, 'g, 'b \<times> 'h, 'h) pre_morph"
  where \<open>c \<equiv> \<lparr>node_map = snd, edge_map = snd\<rparr>\<close>

sublocale c: morphism A C c
  by standard
    (auto simp add: A_def c_def f.mark_preserve g.mark_preserve f.label_preserve g.label_preserve)

(* Proof: Fundamentals of Alg. Graph Trans, Ehrig, Prange Taentzer *)
sublocale pb: pullback_diagram A B C D b c f g
proof
  show \<open>\<^bsub>f \<circ>\<^sub>\<rightarrow> b\<^esub>\<^sub>V v = \<^bsub>g \<circ>\<^sub>\<rightarrow> c\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>A\<^esub>\<close> for v
    using that
    by(auto simp add: A_def b_def c_def morph_comp_def)
next
  show ce: \<open>\<^bsub>f \<circ>\<^sub>\<rightarrow> b\<^esub>\<^sub>E e = \<^bsub>g \<circ>\<^sub>\<rightarrow> c\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>A\<^esub>\<close> for e
    using that
    by(auto simp add: A_def b_def c_def morph_comp_def)
next
  show \<open>Ex1M (\<lambda>x. morphism A' A x
          \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v)
          \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e)
          \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v)
          \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e))
            A'\<close>
    if A':\<open>graph A'\<close> and
      \<open>morphism A' C c'\<close>
      \<open>morphism A' B b'\<close>
      \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>g \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close>
      \<open>\<And>e. e \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>g \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close>
    for A' :: "('c, 'd) ngraph" and c' b'
  proof -

    interpret b': morphism A' B b'
      using \<open>morphism A' B b'\<close>
      by assumption

     interpret c': morphism A' C c'
       using \<open>morphism A' C c'\<close>
       by assumption

    define u :: "(nat, 'a \<times> 'g, nat, 'b \<times> 'h) pre_morph" where
      \<open>u \<equiv> \<lparr>node_map = \<lambda>v. (\<^bsub>b'\<^esub>\<^sub>V v, \<^bsub>c'\<^esub>\<^sub>V v)
           ,edge_map = \<lambda>e. (\<^bsub>b'\<^esub>\<^sub>E e, \<^bsub>c'\<^esub>\<^sub>E e)\<rparr>\<close>

    interpret u: morphism A' A u
    proof
      show ue: \<open>\<^bsub>u\<^esub>\<^sub>E e \<in> E\<^bsub>A\<^esub>\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
        using \<open>\<And>e. e \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>g \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close>
            that  b'.morph_edge_range  c'.morph_edge_range
        by(simp add: u_def A_def morph_comp_def)
    next
      show \<open>\<^bsub>u\<^esub>\<^sub>V v \<in> V\<^bsub>A\<^esub>\<close> if \<open>v \<in> V\<^bsub>A'\<^esub>\<close> for v
        using \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>g \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close>
            that  b'.morph_node_range  c'.morph_node_range
        by(simp add: u_def A_def morph_comp_def)
    next
      show \<open>\<^bsub>u\<^esub>\<^sub>V (s\<^bsub>A'\<^esub> e) = s\<^bsub>A\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
        by(simp add: u_def A_def morph_comp_def b'.source_preserve c'.source_preserve that)
    next
      show \<open>\<^bsub>u\<^esub>\<^sub>V (t\<^bsub>A'\<^esub> e) = t\<^bsub>A\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
        by(simp add: u_def A_def morph_comp_def b'.target_preserve c'.target_preserve that)
    next
      show \<open>l\<^bsub>A'\<^esub> v = l\<^bsub>A\<^esub> (\<^bsub>u\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>A'\<^esub>\<close> for v
        by (simp add: u_def A_def b'.label_preserve to_ngraph_def that)
    next
      show \<open>m\<^bsub>A'\<^esub> e = m\<^bsub>A\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
        by (simp add: u_def A_def b'.mark_preserve to_ngraph_def that)
    qed

    show ?thesis
    proof (rule_tac x = u in exI, intro conjI)
      show \<open>morphism A' A u\<close>
        using u.morphism_axioms
        by assumption
    next
      show \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v\<close>
        by (simp add: b_def u_def morph_comp_def)
    next
      show \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e\<close>
        by (simp add: b_def u_def morph_comp_def)
  next
    show \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
      by (simp add: c_def u_def morph_comp_def)
  next
    show \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
      by (simp add: c_def u_def morph_comp_def)
  next
    show \<open>\<forall>y. morphism A' A y
      \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> y\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v)
      \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> y\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e)
      \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> y\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v)
      \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> y\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e)
      \<longrightarrow> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>y\<^esub>\<^sub>E e = \<^bsub>u\<^esub>\<^sub>E e) \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>y\<^esub>\<^sub>V v = \<^bsub>u\<^esub>\<^sub>V v)\<close>
    proof safe
      show \<open>\<^bsub>u'\<^esub>\<^sub>E e = \<^bsub>u\<^esub>\<^sub>E e\<close>
        if \<open>morphism A' A u'\<close>
          and \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v\<close>
          and \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e\<close>
          and \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
          and \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
          and \<open>e \<in> E\<^bsub>A'\<^esub>\<close>
        for u' e
      proof -
        have \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. fst (\<^bsub>u'\<^esub>\<^sub>E e) = \<^bsub>b'\<^esub>\<^sub>E e\<close>
          using \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e\<close>
          by (simp add: b_def morph_comp_def)
        moreover

        have \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. snd (\<^bsub>u'\<^esub>\<^sub>E e) = \<^bsub>c'\<^esub>\<^sub>E e\<close>
          using \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
          by (simp add: c_def morph_comp_def)

        ultimately show ?thesis
          using \<open>e \<in> E\<^bsub>A'\<^esub>\<close>
          by (simp add: u_def) (metis surjective_pairing)
      qed
    next
      show \<open>\<^bsub>u'\<^esub>\<^sub>V v = \<^bsub>u\<^esub>\<^sub>V v\<close>
        if \<open>morphism A' A u'\<close>
          and \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v\<close>
          and \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e\<close>
          and \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
          and \<open>\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
          and \<open>v \<in> V\<^bsub>A'\<^esub>\<close>
        for u' v
      proof -
        have \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. fst (\<^bsub>u'\<^esub>\<^sub>V v) = \<^bsub>b'\<^esub>\<^sub>V v\<close>
          using \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>b \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v\<close>
          by (simp_all add: b_def morph_comp_def)
        moreover

        have \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. snd (\<^bsub>u'\<^esub>\<^sub>V v) = \<^bsub>c'\<^esub>\<^sub>V v\<close>
          using \<open>\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>c \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
          by (simp add: c_def morph_comp_def)

        ultimately show ?thesis
          using \<open>v \<in> V\<^bsub>A'\<^esub>\<close>
          by (simp add: u_def) (metis surjective_pairing)
    qed
  qed
qed
qed
qed

lemma g_inj_imp_b_inj:
  assumes g:\<open>injective_morphism C D g\<close>
  shows \<open>injective_morphism A B b\<close>
proof -
  interpret g: injective_morphism C D g
    using g by assumption

  show ?thesis
  proof
    show \<open>inj_on \<^bsub>b\<^esub>\<^sub>V V\<^bsub>A\<^esub>\<close>
      using g.inj_nodes
      by (simp add: A_def b_def inj_on_def)
  next
    show \<open>inj_on \<^bsub>b\<^esub>\<^sub>E E\<^bsub>A\<^esub>\<close>
      using g.inj_edges
      by (simp add: A_def b_def inj_on_def)
  qed
qed

(* Lifted version *)
lemma (in pullback_diagram) g_inj_imp_b_inj:
  assumes g:\<open>injective_morphism C D g\<close>
  shows \<open>injective_morphism A B b\<close>
proof -
  interpret g: injective_morphism C D g
    using g by assumption

  interpret pb: pullback_construction ..

  interpret pbc: injective_morphism pb.A B pb.b
    using pb.g_inj_imp_b_inj[OF g] by assumption

  obtain u where \<open>bijective_morphism A pb.A u\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>pb.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>pb.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b\<^esub>\<^sub>E e\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>pb.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>pb.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c\<^esub>\<^sub>E e\<close>
    using pullback_diagram_axioms pb.pb.uniqueness_pb[OF b.G.graph_axioms b.morphism_axioms c.morphism_axioms]
    by fast
  interpret u: bijective_morphism A pb.A u
    using \<open>bijective_morphism A pb.A u\<close> by assumption

  interpret uc: injective_morphism A B \<open>pb.b \<circ>\<^sub>\<rightarrow> u\<close>
    using inj_comp_inj[OF u.injective_morphism_axioms pbc.injective_morphism_axioms]
    by assumption

  show ?thesis
  proof
    show \<open>inj_on \<^bsub>b\<^esub>\<^sub>V V\<^bsub>A\<^esub>\<close>
      using \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>pb.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b\<^esub>\<^sub>V v\<close> uc.inj_nodes
      by (simp add: inj_on_def)
  next
    show \<open>inj_on \<^bsub>b\<^esub>\<^sub>E E\<^bsub>A\<^esub>\<close>
      using \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>pb.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b\<^esub>\<^sub>E e\<close> uc.inj_edges
      by (simp add: inj_on_def)
  qed
qed

lemma reduced_chain_condition_nodes:
  fixes x y
  assumes
    \<open>x \<in> V\<^bsub>B\<^esub>\<close>
    \<open>y \<in> V\<^bsub>C\<^esub>\<close>
    \<open>\<^bsub>f\<^esub>\<^sub>V x = \<^bsub>g\<^esub>\<^sub>V y\<close>
  shows \<open>(\<exists>a1 \<in> V\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>V a1 = x) \<and> (\<exists>a2 \<in> V\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>V a2 = y)\<close>
proof
  show \<open>\<exists>a1\<in>V\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>V a1 = x\<close>
    using assms
    by (auto simp add: A_def b_def)
next
  show \<open>\<exists>a2\<in>V\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>V a2 = y\<close>
    using assms
    by (auto simp add: A_def c_def)
qed

lemma (in pullback_diagram) reduced_chain_condition_nodes:
  fixes x y
  assumes
    \<open>x \<in> V\<^bsub>B\<^esub>\<close>
    \<open>y \<in> V\<^bsub>C\<^esub>\<close>
    \<open>\<^bsub>f\<^esub>\<^sub>V x = \<^bsub>g\<^esub>\<^sub>V y\<close>
  shows \<open>(\<exists>a1 \<in> V\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>V a1 = x) \<and> (\<exists>a2 \<in> V\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>V a2 = y)\<close>
proof -
  interpret constr: pullback_construction ..

 obtain u where \<open>bijective_morphism A constr.A u\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b\<^esub>\<^sub>E e\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c\<^esub>\<^sub>E e\<close>
    using pullback_diagram_axioms constr.pb.uniqueness_pb[OF b.G.graph_axioms b.morphism_axioms c.morphism_axioms]
    by fast

  interpret u: bijective_morphism A constr.A u
    using \<open>bijective_morphism A constr.A u\<close> by assumption

  show ?thesis
    using constr.reduced_chain_condition_nodes[OF assms]
      \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b\<^esub>\<^sub>V v\<close>
      \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c\<^esub>\<^sub>V v\<close>
      u.surj_nodes
    by (fastforce simp: morph_comp_def)
qed

lemma reduced_chain_condition_edges:
  fixes x y
  assumes
    \<open>x \<in> E\<^bsub>B\<^esub>\<close>
    \<open>y \<in> E\<^bsub>C\<^esub>\<close>
    \<open>\<^bsub>f\<^esub>\<^sub>E x = \<^bsub>g\<^esub>\<^sub>E y\<close>
  shows \<open>(\<exists>a1 \<in> E\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>E a1 = x) \<and> (\<exists>a2 \<in> E\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>E a2 = y)\<close>
proof
  show \<open>\<exists>a1\<in>E\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>E a1 = x\<close>
    using assms
    by (auto simp add: A_def b_def)
next
  show \<open>\<exists>a2\<in>E\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>E a2 = y\<close>
    using assms
    by (auto simp add: A_def c_def)
qed

lemma (in pullback_diagram) reduced_chain_condition_edges:
  fixes x y
  assumes
    \<open>x \<in> E\<^bsub>B\<^esub>\<close>
    \<open>y \<in> E\<^bsub>C\<^esub>\<close>
    \<open>\<^bsub>f\<^esub>\<^sub>E x = \<^bsub>g\<^esub>\<^sub>E y\<close>
  shows \<open>(\<exists>a1 \<in> E\<^bsub>A\<^esub>. \<^bsub>b\<^esub>\<^sub>E a1 = x) \<and> (\<exists>a2 \<in> E\<^bsub>A\<^esub>. \<^bsub>c\<^esub>\<^sub>E a2 = y)\<close>
proof -
  interpret constr: pullback_construction ..

 obtain u where \<open>bijective_morphism A constr.A u\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>b\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b\<^esub>\<^sub>E e\<close>
    \<open>\<forall>v\<in>V\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c\<^esub>\<^sub>V v\<close> \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c\<^esub>\<^sub>E e\<close>
    using pullback_diagram_axioms constr.pb.uniqueness_pb[OF b.G.graph_axioms b.morphism_axioms c.morphism_axioms]
    by fast

  interpret u: bijective_morphism A constr.A u
    using \<open>bijective_morphism A constr.A u\<close> by assumption

  show ?thesis
    using constr.reduced_chain_condition_edges[OF assms]
      \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.b \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>b\<^esub>\<^sub>E e\<close>
      \<open>\<forall>e\<in>E\<^bsub>A\<^esub>. \<^bsub>constr.c \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c\<^esub>\<^sub>E e\<close>
      u.surj_edges
    by (fastforce simp: morph_comp_def)
qed

end

(*

lemma pushout_pullback_decomposition:
  assumes
    "1+2": \<open>pushout_diagram A E C F (r \<circ>\<^sub>\<rightarrow> k) l v (w \<circ>\<^sub>\<rightarrow> u)\<close> and
    "2pb": \<open>pullback_diagram B E D F r s v w\<close> and
        w: \<open>injective_morphism D F w\<close> and
        k: \<open>injective_morphism A B k\<close>
  shows \<open> pushout_diagram A B C D k l s u
        \<and> pullback_diagram A B C D k l s u
        \<and> pushout_diagram B E D F r s v w\<close>
proof -
  interpret "1+2": pushout_diagram A E C F "r \<circ>\<^sub>\<rightarrow> k" l v "w \<circ>\<^sub>\<rightarrow> u"
    using "1+2" by assumption

  interpret "2pb": pullback_diagram B E D F r s v w
    using "2pb" by assumption

  interpret w: injective_morphism D F w
    using w by assumption

  interpret k: injective_morphism A B k
    using k by assumption

  (* proof  https://link.springer.com/content/pdf/10.1007/3-540-31188-2.pdf?pdf=button
      PDF P. 104
  *)
  interpret r: injective_morphism B E r
    using "2pb.g_inj_imp_b_inj"[OF w] by assumption

  interpret "rk": injective_morphism A E "r \<circ>\<^sub>\<rightarrow> k"
    using inj_comp_inj[OF k r.injective_morphism_axioms] by assumption

  show ?thesis
    sorry
qed *)
end


subsection \<open>Semantics Based on DBMs\<close>

theory DBM_Zone_Semantics
imports TA_DBM_Operations
begin

no_notation infinity ("\<infinity>")
hide_const (open) D

subsection \<open>Single Step\<close>

inductive step_z_dbm ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> 't :: {linordered_cancel_ab_monoid_add,uminus} DBM
    \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a action \<Rightarrow> 's \<Rightarrow> 't DBM \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^bsub>_,_,_\<^esub> \<langle>_, _\<rangle>" [61,61,61,61] 61)
where
  step_t_z_dbm:
    "D_inv = abstr (inv_of A l) (\<lambda>i j. \<infinity>) v \<Longrightarrow> A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l,And (up D) D_inv\<rangle>" |
  step_a_z_dbm:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'
    \<Longrightarrow> A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a\<^esub> \<langle>l',And (reset' (And D (abstr g (\<lambda>i j. \<infinity>) v)) n r v 0)
                                             (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v)\<rangle>"
inductive_cases step_z_t_cases: "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l', D'\<rangle>"
inductive_cases step_z_a_cases: "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a\<^esub> \<langle>l', D'\<rangle>"
lemmas step_z_cases = step_z_a_cases step_z_t_cases

declare step_z_dbm.intros[intro]

lemma step_z_dbm_preserves_int_all:
  fixes D D' :: "('t :: {time, ring_1} DBM)"
  assumes "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l',D'\<rangle>" "global_clock_numbering A v n" "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>"
          "dbm_int_all D"
  shows "dbm_int_all D'"
using assms
proof (cases, goal_cases)
  case (1 D'')
  hence "\<forall>c\<in>clk_set A. v c \<le> n" by blast+
  from dbm_int_all_inv_abstr[OF 1(2)] 1 have D''_int: "dbm_int_all D''" by simp
  show ?thesis unfolding 1(6)
    by (intro And_int_all_preservation up_int_all_preservation dbm_int_inv_abstr D''_int 1)
next
  case (2 g a r)
  hence assms: "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n"
    by blast+
  from dbm_int_all_inv_abstr[OF 2(2)] have D'_int:
    "dbm_int_all (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v)"
  by simp
  from dbm_int_all_guard_abstr 2 have D''_int: "dbm_int_all (abstr g (\<lambda>i j. \<infinity>) v)" by simp
  have "set r \<subseteq> clk_set A" using 2(6) unfolding trans_of_def collect_clkvt_def by fastforce
  hence *:"\<forall>c\<in>set r. v c \<le> n" using assms(2) by fastforce
  show ?thesis unfolding 2(5)
  by (intro And_int_all_preservation DBM_reset'_int_all_preservation dbm_int_all_inv_abstr 2 D''_int)
     (simp_all add: assms(1) *)
qed

lemma step_z_dbm_preserves_int:
  fixes D D' :: "('t :: {time, ring_1} DBM)"
  assumes "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l',D'\<rangle>" "global_clock_numbering A v n" "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>"
          "dbm_int D n"
  shows "dbm_int D' n"
using assms
proof (cases, goal_cases)
  case (1 D'')
  from dbm_int_inv_abstr[OF 1(2)] 1 have D''_int: "dbm_int D'' n" by simp
  show ?thesis unfolding 1(6)
    by (intro And_int_preservation up_int_preservation dbm_int_inv_abstr D''_int 1)
next
  case (2 g a r)
  hence assms: "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n"
    by blast+
  from dbm_int_inv_abstr[OF 2(2)] have D'_int: "dbm_int (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v) n"
    by simp
  from dbm_int_guard_abstr 2 have D''_int: "dbm_int (abstr g (\<lambda>i j. \<infinity>) v) n" by simp
  have "set r \<subseteq> clk_set A" using 2(6) unfolding trans_of_def collect_clkvt_def by fastforce
  hence *:"\<forall>c\<in>set r. v c \<le> n" using assms(2) by fastforce
  show ?thesis unfolding 2(5)
  by (intro And_int_preservation DBM_reset'_int_preservation dbm_int_inv_abstr 2 D''_int)
     (simp_all add: assms(1) 2(2) *)
qed

lemma up_correct:
  assumes "clock_numbering' v n"
  shows "[up M]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>\<^sup>\<up>"
using assms
 apply safe
  apply (rule DBM_up_sound')
   apply assumption+
 apply (rule DBM_up_complete')
  apply auto
done

lemma step_z_dbm_sound:
  assumes "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle>" "global_clock_numbering A v n"
  shows "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', [D']\<^bsub>v,n\<^esub>\<rangle>"
using assms
proof (cases, goal_cases)
  case (1 D'')
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" by blast+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  from 1 have D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l}" using dbm_abstr_zone_eq[OF assms(2) *] by metis
  with And_correct have A11: "[And D D'']\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})" by blast
  from D'' have
    "[D']\<^bsub>v,n\<^esub> = ([up D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})"
    unfolding 1(4) And_correct[symmetric] by simp
  with up_correct[OF assms(2)] A11 have "[D']\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>)\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}" by metis
  then show ?thesis by (auto simp: 1(2,3))
next
  case (2 g a r)
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" "\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k)" by blast+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l'). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  have D':
    "[abstr (inv_of A l') (\<lambda>i j. \<infinity>) v]\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l'}"
  using 2 dbm_abstr_zone_eq[OF assms(2) *] by simp
  from assms(3) 2(4) have *: "\<forall>c\<in>collect_clks g. v c \<le> n"
  unfolding clkp_set_def collect_clkt_def inv_of_def by (fastforce simp: collect_clks_id)
  have D'':"[abstr g (\<lambda>i j. \<infinity>) v]\<^bsub>v,n\<^esub> = {u. u \<turnstile> g}" using 2 dbm_abstr_zone_eq[OF assms(2) *] by auto
  with And_correct have A11: "[And D (abstr g (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
  let ?D = "reset' (And D (abstr g (\<lambda>i j. \<infinity>) v)) n r v 0"
  have "set r \<subseteq> clk_set A" using 2(4) unfolding trans_of_def collect_clkvt_def by fastforce
  hence **:"\<forall>c\<in>set r. v c \<le> n" using assms(3) by fastforce
  have D_reset: "[?D]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
  proof safe
    fix u assume u: "u \<in> [?D]\<^bsub>v,n\<^esub>"
    from DBM_reset'_sound[OF assms(4,2) ** this] obtain ts where
      "set_clocks r ts u \<in> [And D (abstr g (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub>"
    by auto
    with A11 have *: "set_clocks r ts u \<in> ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
    from DBM_reset'_resets[OF assms(4,2) **] u
    have "\<forall>c \<in> set r. u c = 0" unfolding DBM_zone_repr_def by auto
    from reset_set[OF this] have "[r\<rightarrow>0]set_clocks r ts u = u" by simp
    with * show "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r" unfolding zone_set_def by force
  next
    fix u assume u: "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
    from DBM_reset'_complete[OF _ assms(2) **] u A11
    show "u \<in> [?D]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def zone_set_def by force
  qed
  from D' And_correct D_reset have A22:
    "[And ?D (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub> = ([?D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l'})"
  by blast
  with D_reset 2(2-4) show ?thesis by auto
qed

lemma step_z_dbm_DBM:
  assumes "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z\<rangle>" "global_clock_numbering A v n"
  obtains D' where "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle>" "Z = [D']\<^bsub>v,n\<^esub>"
using assms
proof (cases, goal_cases)
  case 1
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" by metis+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D'' where D''_def: "D'' = abstr (inv_of A l) (\<lambda>i j. \<infinity>) v" by auto
  hence D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l}" using dbm_abstr_zone_eq[OF assms(2) *] by metis
  obtain D_up where D_up': "D_up = up D" by blast
  with up_correct assms(2) have D_up: "[D_up]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>)\<^sup>\<up>" by metis
  obtain A2 where A2: "A2 = And D_up D''" by fast
  with And_correct D'' have A22: "[A2]\<^bsub>v,n\<^esub> = ([D_up]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})" by blast
  have "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l, A2\<rangle>" unfolding A2 D_up' D''_def by blast
  moreover have
    "[A2]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>)\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  unfolding A22 D_up ..
  ultimately show thesis using 1 by (intro that[of A2]) auto
next
  case (2 g a r)
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" "\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k)" by metis+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l'). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D' where D'_def: "D' = abstr (inv_of A l') (\<lambda>i j. \<infinity>) v" by blast
  hence D':"[D']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l'}" using dbm_abstr_zone_eq[OF assms(2) *] by simp
  from assms(3) 2(5) have *: "\<forall>c\<in>collect_clks g. v c \<le> n"
  unfolding clkp_set_def collect_clkt_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D'' where D''_def: "D'' = abstr g (\<lambda>i j. \<infinity>) v" by blast
  hence D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> g}" using dbm_abstr_zone_eq[OF assms(2) *] by auto
  obtain A1 where A1: "A1 = And D D''" by fast
  with And_correct D'' have A11: "[A1]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
  let ?D = "reset' A1 n r v 0"
  have "set r \<subseteq> clk_set A" using 2(5) unfolding trans_of_def collect_clkvt_def by fastforce
  hence **:"\<forall>c\<in>set r. v c \<le> n" using assms(3) by fastforce
  have D_reset: "[?D]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
  proof safe
    fix u assume u: "u \<in> [?D]\<^bsub>v,n\<^esub>"
    from DBM_reset'_sound[OF assms(4,2) ** this] obtain ts where
      "set_clocks r ts u \<in> [A1]\<^bsub>v,n\<^esub>"
    by auto
    with A11 have *: "set_clocks r ts u \<in> ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
    from DBM_reset'_resets[OF assms(4,2) **] u
    have "\<forall>c \<in> set r. u c = 0" unfolding DBM_zone_repr_def by auto
    from reset_set[OF this] have "[r\<rightarrow>0]set_clocks r ts u = u" by simp
    with * show "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r" unfolding zone_set_def by force
  next
    fix u assume u: "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
    from DBM_reset'_complete[OF _ assms(2) **] u A11
    show "u \<in> [?D]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def zone_set_def by force
  qed
  obtain A2 where A2: "A2 = And ?D D'" by fast
  with And_correct D' have A22: "[A2]\<^bsub>v,n\<^esub> = ([?D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l'})" by blast
  from 2(5) A2 D'_def D''_def A1 have "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a\<^esub> \<langle>l',A2\<rangle>" by blast
  moreover from A22 D_reset have
    "[A2]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  by auto
  ultimately show ?thesis using 2 by (intro that[of A2]) simp+
qed

lemma step_z_computable:
  assumes "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',Z\<rangle>" "global_clock_numbering A v n"
  obtains D' where "Z = [D']\<^bsub>v,n\<^esub>"
using step_z_dbm_DBM[OF assms] by blast

lemma step_z_dbm_complete:
  assumes "global_clock_numbering A v n" "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"
  and     "u \<in> [(D )]\<^bsub>v,n\<^esub>"
  shows "\<exists> D' a. A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l',D'\<rangle> \<and> u' \<in> [D']\<^bsub>v,n\<^esub>"
proof -
  note A = assms
  from step_z_complete[OF A(2,3)] obtain Z' a where Z':
    "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l',Z'\<rangle>" "u' \<in> Z'" by auto
  with step_z_dbm_DBM[OF Z'(1) A(1)] obtain D' where D':
    "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l',D'\<rangle>" "Z' = [D']\<^bsub>v,n\<^esub>"
  by metis
  with Z'(2) show ?thesis by auto
qed

subsection \<open>Additional Useful Properties\<close>

lemma step_z_equiv:
  assumes "global_clock_numbering A v n" "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z\<rangle>" "[D]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  shows "A \<turnstile> \<langle>l, [M]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z\<rangle>"
using step_z_dbm_complete[OF assms(1)] step_z_dbm_sound[OF _ assms(1), THEN step_z_sound]
assms(2,3) by force

lemma step_z_dbm_equiv:
  assumes "global_clock_numbering A v n" "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle>" "[D]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  shows "\<exists> M'. A \<turnstile> \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M'\<rangle> \<and> [D']\<^bsub>v,n\<^esub> = [M']\<^bsub>v,n\<^esub>"
proof -
  from step_z_dbm_sound[OF assms(2,1)] have "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', [D']\<^bsub>v,n\<^esub>\<rangle>" .
  with step_z_equiv[OF assms(1) this assms(3)] have "A \<turnstile> \<langle>l, [M]\<^bsub>v,n\<^esub>\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', [D']\<^bsub>v,n\<^esub>\<rangle>" by auto
  from step_z_dbm_DBM[OF this assms(1)] show ?thesis by auto
qed

lemma step_z_empty:
  assumes "A \<turnstile> \<langle>l, {}\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z\<rangle>"
  shows "Z = {}"
using step_z_sound[OF assms] by auto

lemma step_z_dbm_empty:
  assumes "global_clock_numbering A v n" "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle>" "[D]\<^bsub>v,n\<^esub> = {}"
  shows "[D']\<^bsub>v,n\<^esub> = {}"
using step_z_dbm_sound[OF assms(2,1)] assms(3) by - (rule step_z_empty, auto)

end