theory Reachability_Analysis
imports
  Flow
  Poincare_Map
begin

lemma not_mem_eq_mem_not: "a \<notin> A \<longleftrightarrow> a \<in> - A"
  by auto

lemma continuous_orderD:
  fixes g::"'b::t2_space \<Rightarrow> 'c::order_topology"
  assumes "continuous (at x within S) g"
  shows "g x > c \<Longrightarrow> \<forall>\<^sub>F y in at x within S. g y > c"
    "g x < c \<Longrightarrow> \<forall>\<^sub>F y in at x within S. g y < c"
  using order_tendstoD[OF assms[unfolded continuous_within]]
  by auto

lemma frontier_halfspace_component_ge: "n \<noteq> 0 \<Longrightarrow> frontier {x. c \<le> x \<bullet> n} = plane n c"
  apply (subst (1) inner_commute)
  apply (subst (2) inner_commute)
  apply (subst frontier_halfspace_ge[of n c])
  by auto

lemma closed_Collect_le_within:
  fixes f g :: "'a :: topological_space \<Rightarrow> 'b::linorder_topology"
  assumes f: "continuous_on UNIV f"
    and g: "continuous_on UNIV g"
    and "closed R"
  shows "closed {x \<in> R. f x \<le> g x}"
proof -
  have *: "- R \<union> {x. g x < f x} = - {x \<in> R. f x \<le> g x}"
    by auto
  have "open (-R)" using assms by auto
  from open_Un[OF this open_Collect_less [OF g f], unfolded *]
  show ?thesis
    by (simp add: closed_open)
qed

subsection \<open>explicit representation of hyperplanes / halfspaces\<close>

datatype 'a sctn = Sctn (normal: 'a) (pstn: real)

definition "le_halfspace sctn x \<longleftrightarrow> x \<bullet> normal sctn \<le> pstn sctn"

definition "lt_halfspace sctn x \<longleftrightarrow> x \<bullet> normal sctn < pstn sctn"

definition "ge_halfspace sctn x \<longleftrightarrow> x \<bullet> normal sctn \<ge> pstn sctn"

definition "gt_halfspace sctn x \<longleftrightarrow> x \<bullet> normal sctn > pstn sctn"

definition "plane_of sctn = {x. x \<bullet> normal sctn = pstn sctn}"

definition "above_halfspace sctn = Collect (ge_halfspace sctn)"

definition "below_halfspace sctn = Collect (le_halfspace sctn)"

definition "sbelow_halfspace sctn = Collect (lt_halfspace sctn)"

definition "sabove_halfspace sctn = Collect (gt_halfspace sctn)"

subsection \<open>explicit H representation of polytopes (mind \<open>Polytopes.thy\<close>)\<close>

definition below_halfspaces
where "below_halfspaces sctns = \<Inter>(below_halfspace ` sctns)"

definition sbelow_halfspaces
where "sbelow_halfspaces sctns = \<Inter>(sbelow_halfspace ` sctns)"

definition above_halfspaces
where "above_halfspaces sctns = \<Inter>(above_halfspace ` sctns)"

definition sabove_halfspaces
where "sabove_halfspaces sctns = \<Inter>(sabove_halfspace ` sctns)"

lemmas halfspace_simps =
  above_halfspace_def
  sabove_halfspace_def
  below_halfspace_def
  sbelow_halfspace_def
  below_halfspaces_def
  sbelow_halfspaces_def
  above_halfspaces_def
  sabove_halfspaces_def
  ge_halfspace_def[abs_def]
  gt_halfspace_def[abs_def]
  le_halfspace_def[abs_def]
  lt_halfspace_def[abs_def]

subsection \<open>predicates for reachability analysis\<close>

context c1_on_open_euclidean
begin

definition flowpipe ::
  "(('a::euclidean_space) \<times> ('a \<Rightarrow>\<^sub>L 'a)) set \<Rightarrow> real \<Rightarrow> real \<Rightarrow>
   ('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set \<Rightarrow> ('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set \<Rightarrow> bool"
where "flowpipe X0 hl hu CX X1 \<longleftrightarrow> 0 \<le> hl \<and> hl \<le> hu \<and> fst ` X0 \<subseteq> X \<and> fst ` CX \<subseteq> X \<and> fst ` X1 \<subseteq> X \<and>
  (\<forall>(x0, d0) \<in> X0. \<forall>h \<in> {hl .. hu}.
    h \<in> existence_ivl0 x0 \<and> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> X1 \<and> (\<forall>h' \<in> {0 .. h}. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX))"

lemma flowpipeD:
  assumes "flowpipe X0 hl hu CX X1"
  shows flowpipe_safeD: "fst ` X0 \<union> fst ` CX \<union> fst ` X1 \<subseteq> X"
    and flowpipe_nonneg: "0 \<le> hl" "hl \<le> hu"
    and flowpipe_exivl: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0, d0) \<in> X0 \<Longrightarrow> h \<in> existence_ivl0 x0"
    and flowpipe_discrete: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0, d0) \<in> X0 \<Longrightarrow> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> X1"
    and flowpipe_cont: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0, d0) \<in> X0 \<Longrightarrow> 0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX"
  using assms
  by (auto simp: flowpipe_def)

lemma flowpipe_source_subset: "flowpipe X0 hl hu CX X1 \<Longrightarrow> X0 \<subseteq> CX"
  apply (auto dest: bspec[where x=hl] bspec[where x=0] simp: flowpipe_def)
  apply (drule bspec)
   apply (assumption)
  apply auto
  apply (drule bspec[where x=hl])
   apply auto
  apply (drule bspec[where x=0])
  by (auto simp: flow_initial_time_if)

definition "flowsto X0 T CX X1 \<longleftrightarrow>
  (\<forall>(x0, d0) \<in> X0. \<exists>h \<in> T. h \<in> existence_ivl0 x0 \<and> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> X1 \<and> (\<forall>h' \<in> open_segment 0 h. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX))"

lemma flowsto_from_empty_iff[simp]: "flowsto {} t b c"
  by (auto simp: simp: flowsto_def)

lemma flowsto_empty_time_iff[simp]: "flowsto a {} b c \<longleftrightarrow> a = {}"
  by (auto simp: simp: flowsto_def)

lemma flowstoE:
  assumes "flowsto X0 T CX X1" "(x0, d0) \<in> X0"
  obtains h where "h \<in> T" "h \<in> existence_ivl0 x0" "(flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> X1"
    "\<And>h'. h' \<in> open_segment 0 h \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX"
  using assms
  by (auto simp: flowsto_def)

lemma flowsto_safeD: "flowsto X0 T CX X1 \<Longrightarrow> fst ` X0 \<subseteq> X"
  by (auto simp: flowsto_def split_beta' mem_existence_ivl_iv_defined)

lemma flowsto_union:
  assumes 1: "flowsto X0 T CX Y" and 2: "flowsto Z S CZ W"
  shows "flowsto (X0 \<union> Z) (T \<union> S) (CX \<union> CZ) (Y \<union> W)"
  using assms unfolding flowsto_def
  by force

lemma flowsto_subset:
  assumes "flowsto X0 T CX Y"
  assumes "Z \<subseteq> X0" "T \<subseteq> S" "CX \<subseteq> CZ" "Y \<subseteq> W"
  shows "flowsto Z S CZ W"
  unfolding flowsto_def
  using assms
  by (auto elim!: flowstoE) blast

lemmas flowsto_unionI = flowsto_subset[OF flowsto_union]

lemma flowsto_unionE:
  assumes "flowsto X0 T CX (Y \<union> Z)"
  obtains X1 X2 where "X0 = X1 \<union> X2" "flowsto X1 T CX Y" "flowsto X2 T CX Z"
proof -
  let ?X1 = "{x\<in>X0. flowsto {x} T CX Y}"
  let ?X2 = "{x\<in>X0. flowsto {x} T CX Z}"
  from assms have "X0 = ?X1 \<union> ?X2" "flowsto ?X1 T CX Y" "flowsto ?X2 T CX Z"
    by (auto simp: flowsto_def)
  thus ?thesis ..
qed

lemma flowsto_trans:
  assumes A: "flowsto A S B C" and C: "flowsto C T D E"
  shows "flowsto A {s + t |s t. s \<in> S \<and> t \<in> T} (B \<union> D \<union> C) E"
  unfolding flowsto_def
proof safe
  fix x0 d0 assume x0: "(x0, d0) \<in> A"
  from flowstoE[OF A x0]
  obtain h where h: "h \<in> S" "h \<in> existence_ivl0 x0" "(flow0 x0 h, (Dflow x0 h) o\<^sub>L d0) \<in> C"
    "\<And>h'. h' \<in> {0<--<h} \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> B"
    by auto
  from h(2) have x0[simp]: "x0 \<in> X" by auto
  from flowstoE[OF C \<open>_ \<in> C\<close>]
  obtain i where i: "i \<in> T" "i \<in> existence_ivl0 (flow0 x0 h)"
    "(flow0 (flow0 x0 h) i, Dflow (flow0 x0 h) i o\<^sub>L Dflow x0 h o\<^sub>L d0) \<in> E"
    "\<And>h'. h' \<in> {0<--<i} \<Longrightarrow> (flow0 (flow0 x0 h) h', Dflow (flow0 x0 h) h' o\<^sub>L (Dflow x0 h o\<^sub>L d0)) \<in> D"
    by (auto simp: ac_simps)
  have hi: "h + i \<in> existence_ivl0 x0"
    using \<open>h \<in> existence_ivl0 x0\<close> \<open>i \<in> existence_ivl0 (flow0 x0 h)\<close> existence_ivl_trans by blast
  moreover have "(flow0 x0 (h + i), Dflow x0 (h + i) o\<^sub>L d0) \<in> E"
    apply (subst flow_trans)
      apply fact apply fact
    apply (subst Dflow_trans)
      apply fact apply fact
    apply fact
    done
  moreover have "(flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> B \<union> D \<union> C" if "h'\<in>{0<--<h + i}" for h'
  proof cases
    assume "h' \<in> {0 <--< h}"
    then show ?thesis using h by simp
  next
    assume "h' \<notin> {0 <--< h}"
    with that have h': "h' - h \<in> {0 <--< i}" if "h' \<noteq> h"
      using that
      by (auto simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl split: if_splits)
    from i(4)[OF this]
    show ?thesis
      apply (cases "h' = h")
      subgoal using h by force
      subgoal
        apply simp
        apply (subst (asm) flow_trans[symmetric])
        subgoal by (rule h)
        subgoal using \<open>_ \<Longrightarrow> h' - h \<in> {0<--<i}\<close> i(2) local.in_existence_between_zeroI
          apply auto
          using open_closed_segment by blast
        subgoal
          unfolding blinfun_compose_assoc[symmetric]
          apply (subst (asm) Dflow_trans[symmetric])
            apply auto
           apply fact+
          done
        done
      done
  qed
  ultimately show "\<exists>h\<in>{s + t |s t. s \<in> S \<and> t \<in> T}.
      h \<in> existence_ivl0 x0 \<and> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> E \<and> (\<forall>h'\<in>{0<--<h}. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> B \<union> D \<union> C)"
    using \<open>h \<in> S\<close> \<open>i \<in> T\<close>
    by (auto intro!: bexI[where x="h + i"])
qed

lemma flowsto_step:
  assumes A: "flowsto A S B C"
  assumes D: "flowsto D T E F"
  shows "flowsto A (S \<union> {s + t |s t. s \<in> S \<and> t \<in> T}) (B \<union> E \<union> C \<inter> D) (C - D \<union> F)"
proof -
  have "C = (C \<inter> D) \<union> (C - D)" (is "_ = ?C1 \<union> ?C2")
    by auto
  then have "flowsto A S B (?C1 \<union> ?C2)" using A by simp
  from flowsto_unionE[OF this]
  obtain A1 A2 where "A = A1 \<union> A2" and A1: "flowsto A1 S B ?C1" and A2: "flowsto A2 S B ?C2"
    by auto
  have "flowsto ?C1 T E F"
    using D by (rule flowsto_subset) auto
  from flowsto_union[OF flowsto_trans[OF A1 this] A2]
  show ?thesis by (auto simp add: \<open>A = _\<close> ac_simps)
qed

lemma
  flowsto_stepI:
    "flowsto X0 U B C \<Longrightarrow>
    flowsto D T E F \<Longrightarrow>
    Z \<subseteq> X0 \<Longrightarrow>
    (\<And>s. s \<in> U \<Longrightarrow> s \<in> S) \<Longrightarrow>
    (\<And>s t. s \<in> U \<Longrightarrow> t \<in> T \<Longrightarrow> s + t \<in> S) \<Longrightarrow>
    B \<union> E \<union> D \<inter> C \<subseteq> CZ \<Longrightarrow> C - D \<union> F \<subseteq> W \<Longrightarrow> flowsto Z S CZ W"
  by (rule flowsto_subset[OF flowsto_step]) auto

lemma flowsto_imp_flowsto:
  "flowpipe Y h h CY Z \<Longrightarrow> flowsto Y {h} (CY) Z"
  unfolding flowpipe_def flowsto_def
  by (auto simp: open_segment_eq_real_ivl split_beta')

lemma connected_below_halfspace:
  assumes "x \<in> below_halfspace sctn"
  assumes "x \<in> S" "connected S"
  assumes "S \<inter> plane_of sctn = {}"
  shows "S \<subseteq> below_halfspace sctn"
proof -
  note \<open>connected S\<close>
  moreover
  have "open {x. x \<bullet> normal sctn < pstn sctn}" (is "open ?X")
    and "open {x. x \<bullet> normal sctn > pstn sctn}" (is "open ?Y")
    by (auto intro!: open_Collect_less continuous_intros)
  moreover have "?X \<inter> ?Y \<inter> S = {}" "S \<subseteq> ?X \<union> ?Y"
    using assms by (auto simp: plane_of_def)
  ultimately have "?X \<inter> S = {} \<or> ?Y \<inter> S = {}"
    by (rule connectedD)
  then show ?thesis
    using assms
    by (force simp: below_halfspace_def le_halfspace_def plane_of_def)
qed

lemma
  inter_Collect_eq_empty:
  assumes "\<And>x. x \<in> X0 \<Longrightarrow> \<not> g x" shows "X0 \<inter> Collect g = {}"
  using assms by auto

subsection \<open>Poincare Map\<close>

lemma closed_plane_of[simp]: "closed (plane_of sctn)"
  by (auto simp: plane_of_def intro!: closed_Collect_eq continuous_intros)

definition "poincare_mapsto P X0 S CX Y \<longleftrightarrow> (\<forall>(x, d) \<in> X0.
  returns_to P x \<and> fst ` X0 \<subseteq> S \<and>
  (return_time P differentiable at x within S) \<and>
  (\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within S) \<and>
       (poincare_map P x, D o\<^sub>L d) \<in> Y) \<and>
  (\<forall>t\<in>{0<..<return_time P x}. flow0 x t \<in> CX))"

lemma poincare_mapsto_empty[simp]:
  "poincare_mapsto P {} S CX Y"
  by (auto simp: poincare_mapsto_def)

lemma flowsto_eventually_mem_cont:
  assumes "flowsto X0 T CX Y" "(x, d) \<in> X0" "T \<subseteq> {0<..}"
  shows "\<forall>\<^sub>F t in at_right 0. (flow0 x t, Dflow x t o\<^sub>L d) \<in> CX"
proof -
  from flowstoE[OF assms(1,2)] assms(3)
  obtain h where h: "0 < h" "h \<in> T" "h \<in> existence_ivl0 x" "(flow0 x h, (Dflow x h) o\<^sub>L d) \<in> Y" "\<And>h'. h' \<in> {0<--<h} \<Longrightarrow> (flow0 x h', (Dflow x h') o\<^sub>L d) \<in> CX"
    by (auto simp: subset_iff)
  have "\<forall>\<^sub>F x in at_right 0. 0 < x \<and> x < h"
    apply (rule eventually_conj[OF eventually_at_right_less])
    using eventually_at_right h(1) by blast
  then show ?thesis
    by eventually_elim (auto intro!: h simp: open_segment_eq_real_ivl)
qed

lemma frontier_aux_lemma:
  fixes R :: "'n::euclidean_space set"
  assumes "closed R" "R \<subseteq> {x. x \<bullet> n = c}" and [simp]: "n \<noteq> 0"
  shows "frontier {x \<in> R. c \<le> x \<bullet> n} = {x \<in> R. c = x \<bullet> n}"
  apply (auto simp: frontier_closures)
  subgoal by (metis (full_types) Collect_subset assms(1) closure_minimal subsetD)
  subgoal premises prems for x
  proof -
    note prems
    have "closed {x \<in> R. c \<le> x \<bullet> n}"
      by (auto intro!: closed_Collect_le_within continuous_intros assms)
    from closure_closed[OF this] prems(1)
    have "x \<in> R" "c \<le> x \<bullet> n" by auto
    with assms show ?thesis by auto
  qed
  subgoal for x
    using closure_subset by fastforce
  subgoal premises prems for x
  proof -
    note prems
    have *: "{xa \<in> R. x \<bullet> n \<le> xa \<bullet> n} = R"
      using assms prems by auto
    have "interior R \<subseteq> interior (plane n c)"
      by (rule interior_mono) (use assms in auto)
    also have "\<dots> = {}"
      by (subst inner_commute) simp
    finally have R: "interior R = {}" by simp
    have "x \<in> closure (- R)"
      unfolding closure_complement
      by (auto simp: R)
    then show ?thesis
      unfolding * by simp
  qed
  done

lemma blinfun_minus_comp_distrib: "(a - b) o\<^sub>L c = (a o\<^sub>L c) - (b o\<^sub>L c)"
  by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)

lemma flowpipe_split_at_above_halfspace:
  assumes "flowpipe X0 hl t CX Y" "fst ` X0 \<inter> {x. x \<bullet> n \<ge> c} = {}" and [simp]: "n \<noteq> 0"
  assumes cR: "closed R" and Rs: "R \<subseteq> plane n c"
  assumes PDP: "\<And>x d. (x, d) \<in> CX \<Longrightarrow> x \<bullet> n = c \<Longrightarrow> (x,
     d - (blinfun_scaleR_left (f (x)) o\<^sub>L (blinfun_scaleR_left (inverse (f x \<bullet> n)) o\<^sub>L (blinfun_inner_left n o\<^sub>L d)))) \<in> PDP"
  assumes PDP_nz: "\<And>x d. (x, d) \<in> PDP \<Longrightarrow> f x \<bullet> n \<noteq> 0"
  assumes PDP_inR: "\<And>x d. (x, d) \<in> PDP \<Longrightarrow> x \<in> R"
  assumes PDP_in: "\<And>x d. (x, d) \<in> PDP \<Longrightarrow> \<forall>\<^sub>F x in at x within plane n c. x \<in> R"
  obtains X1 X2 where "X0 = X1 \<union> X2"
    "flowsto X1 {0<..t} (CX \<inter> {x. x \<bullet> n < c} \<times> UNIV) (CX \<inter> {x \<in> R. x \<bullet> n = c} \<times> UNIV)"
    "flowsto X2 {hl .. t} (CX \<inter> {x. x \<bullet> n < c} \<times> UNIV) (Y \<inter> ({x. x \<bullet> n < c} \<times> UNIV))"
    "poincare_mapsto {x \<in> R. x \<bullet> n = c} X1 UNIV (fst ` CX \<inter> {x. x \<bullet> n < c}) PDP"
proof -
  let ?sB = "{x. x \<bullet> n < c}"
  let ?A = "{x. x \<bullet> n \<ge> c}"
  let ?P = "{x \<in> R. x \<bullet> n = c}"
  have [intro]: "closed ?A" "closed ?P"
    by (auto intro!: closed_Collect_le_within closed_levelset_within continuous_intros cR
        closed_halfspace_component_ge)
  let ?CX = "CX \<inter> ?sB \<times> UNIV"
  let ?X1 = "{x\<in>X0. flowsto {x} {0 <.. t} ?CX (CX \<inter> (?P \<times> UNIV))}"
  let ?X2 = "{x\<in>X0. flowsto {x} {hl .. t} ?CX (Y \<inter> (?sB \<times> UNIV))}"
  have "(x, d) \<in> ?X1 \<or> (x, d) \<in> ?X2" if "(x, d) \<in> X0" for x d
  proof -
    from that assms have
      t: "t \<in> existence_ivl0 x" "\<And>s. 0 \<le> s \<Longrightarrow> s \<le> t \<Longrightarrow> (flow0 x s, Dflow x s o\<^sub>L d) \<in> CX" "(flow0 x t, Dflow x t o\<^sub>L d) \<in> Y"
        apply (auto simp: flowpipe_def dest!: bspec[where x=t])
      apply (drule bspec[where x="(x, d)"], assumption)
      apply simp
      apply (drule bspec[where x=t], force)
      apply auto
      done
    show ?thesis
    proof (cases "\<forall>s\<in>{0..t}. flow0 x s \<in> ?sB")
      case True
      then have "(x, d) \<in> ?X2" using assms t \<open>(x, d) \<in> X0\<close>
        by (auto simp: flowpipe_def flowsto_def open_segment_eq_real_ivl dest!: bspec[where x="(x, d)"])
      then show ?thesis ..
    next
      case False
      then obtain s where s: "0 \<le> s" "s \<le> t" "flow0 x s \<in> ?A"
        by (auto simp: not_less)
      let ?I = "flow0 x -` ?A \<inter> {0 .. s}"
      from s have exivlI: "0 \<le> s' \<Longrightarrow> s' \<le> s \<Longrightarrow> s' \<in> existence_ivl0 x" for s'
        using ivl_subset_existence_ivl[OF \<open>t \<in> existence_ivl0 x\<close>]
        by auto
      then have "compact ?I"
        unfolding compact_eq_bounded_closed
        by (intro conjI bounded_Int bounded_closed_interval disjI2 closed_vimage_Int)
          (auto intro!: continuous_intros closed_Collect_le_within cR)
      moreover
      from s have "?I \<noteq> {}" by auto
      ultimately have "\<exists>s\<in>?I. \<forall>t\<in>?I. s \<le> t"
        by (rule compact_attains_inf)
      then obtain s' where s': "\<And>s''. 0 \<le> s'' \<Longrightarrow> s'' < s' \<Longrightarrow> flow0 x s'' \<notin> ?A"
          "flow0 x s' \<in> ?A" "0 \<le> s'" "s' \<le> s"
        by (force simp: Ball_def)
      have "flow0 x 0 = x" using local.mem_existence_ivl_iv_defined(2) t(1) by auto
      also have "\<dots> \<notin> ?A" using assms \<open>(x, d) \<in> X0\<close> by auto
      finally have "s' \<noteq> 0" using s' by auto
      then have "0 < s'" using \<open>s' \<ge> 0\<close> by simp
      have False if "flow0 x s' \<in> interior ?A"
      proof -
        from that obtain e where "e > 0" and subset: "ball (flow0 x s') e \<subseteq> ?A"
          by (auto simp: mem_interior)
        from subset have "\<forall>\<^sub>F s'' in at_left s'. ball (flow0 x s') e \<subseteq> ?A" by simp
        moreover
        from flow_continuous[OF exivlI[OF \<open>0 \<le> s'\<close> \<open>s' \<le> s\<close>]]
        have "flow0 x \<midarrow>s'\<rightarrow> flow0 x s'" unfolding isCont_def .
        from tendstoD[OF this \<open>0 < e\<close>]
        have "\<forall>\<^sub>F xa in at_left s'. dist (flow0 x xa) (flow0 x s') < e"
          using eventually_at_split by blast
        then have "\<forall>\<^sub>F s'' in at_left s'. flow0 x s'' \<in> ball (flow0 x s') e"
          by (simp add: dist_commute)
        moreover
        have "\<forall>\<^sub>F s'' in at_left s'. 0 < s''"
          using \<open>0 < s'\<close>
          using eventually_at_left by blast
        moreover
        have "\<forall>\<^sub>F s'' in at_left s'. s'' < s'"
          by (auto simp: eventually_at_filter)
        ultimately
        have "\<forall>\<^sub>F s'' in at_left s'. False"
          by eventually_elim (use s' in auto)
        then show False
          by auto
      qed
      then have "flow0 x s' \<in> frontier ?A"
        unfolding frontier_def
        using \<open>closed ?A\<close> s'
        by auto
      with s' have "(x, d) \<in> ?X1" using assms that s t \<open>0 < s'\<close>
        ivl_subset_existence_ivl[OF \<open>t \<in> existence_ivl0 x\<close>]
        frontier_subset_closed[OF \<open>closed ?A\<close>]
        apply (auto simp: flowsto_def flowpipe_def open_segment_eq_real_ivl frontier_halfspace_component_ge
            intro!:
            dest!: bspec[where x="(x, d)"]
            intro: exivlI)
        apply (safe intro!: bexI[where x=s'])
        subgoal by force
        subgoal premises prems
        proof -
          have CX: "(flow0 x s', Dflow x s' o\<^sub>L d) \<in> CX"
            using prems
            by (auto intro!: prems)
          have "flow0 x s' \<bullet> n = c" using prems by auto
          from PDP_inR[OF PDP[OF CX this]]
          show "flow0 x s' \<in> R" .
        qed
        subgoal by (auto simp: not_le)
        subgoal by force
        done
      then show ?thesis ..
    qed
  qed
  then have "X0 = ?X1 \<union> ?X2" by auto
  moreover
  have X1: "flowsto ?X1 {0 <.. t} ?CX (CX \<inter> (?P \<times> UNIV))"
    and X2: "flowsto ?X2 {hl .. t} ?CX (Y \<inter> (?sB \<times> UNIV))"
    by (auto simp: flowsto_def flowpipe_def)
  moreover
  from assms(2) X1 have "poincare_mapsto ?P ?X1 UNIV (fst ` CX \<inter> {x. x \<bullet> n < c}) PDP"
    unfolding poincare_mapsto_def flowsto_def
    apply clarsimp
    subgoal premises prems for x d t
    proof -
      note prems
      have ret: "returns_to ?P x"
        apply (rule returns_to_outsideI[where t=t])
        using prems \<open>closed ?P\<close>
        by auto
      moreover
      have ret_le: "return_time ?P x \<le> t"
        apply (rule return_time_le[OF ret _ _ \<open>0 < t\<close>])
        using prems \<open>closed ?P\<close> by auto
      from prems have CX: "(flow0 x h', (Dflow x h') o\<^sub>L d) \<in> CX" if "0 < h'" "h' \<le> t" for h'
        using that by (auto simp: open_segment_eq_real_ivl)
      have PDP: "(poincare_map ?P x, Dpoincare_map' n c R x o\<^sub>L d) \<in> PDP"
        unfolding poincare_map_def Dpoincare_map'_def
        unfolding blinfun_compose_assoc blinfun_minus_comp_distrib
        apply (rule PDP)
        using poincare_map_returns[OF ret \<open>closed ?P\<close>] ret_le
        by (auto simp: poincare_map_def intro!: CX return_time_pos ret)
      have "eventually (returns_to ({x \<in> R. x \<bullet> n - c = 0})) (at x)"
        apply (rule eventually_returns_to)
        using PDP_nz[OF PDP] assms(2) \<open>(x, d) \<in> X0\<close> cR PDP_in[OF PDP]
        by (auto intro!: ret derivative_eq_intros blinfun_inner_left.rep_eq[symmetric]
            simp: eventually_at_filter)
      moreover have "return_time ?P differentiable at x"
        apply (rule differentiableI)
        apply (rule return_time_plane_has_derivative)
        using prems ret PDP_nz[OF PDP] PDP cR PDP_in[OF PDP]
        by (auto simp: eventually_at_filter)
      moreover
      have "(\<exists>D. (poincare_map ?P has_derivative blinfun_apply D) (at x) \<and> (poincare_map ?P x, D o\<^sub>L d) \<in> PDP)"
        apply (intro exI[where x="Dpoincare_map' n c R x"])
        using prems ret PDP_nz[OF PDP] PDP cR PDP_in[OF PDP]
        by (auto simp: eventually_at_filter intro!: poincare_map_plane_has_derivative)
      moreover have
        "flow0 x h \<in> fst ` CX \<and> (c > flow0 x h \<bullet> n)"
        if "0 < h" "h < return_time ?P x" for h
        using CX[of h] ret that ret_le \<open>0 < h\<close>
        apply (auto simp: open_segment_eq_real_ivl intro!: image_eqI[where x="(flow0 x h, (Dflow x h) o\<^sub>L d)"])
        using prems
        by (auto simp add: open_segment_eq_real_ivl dest!: bspec[where x=t])
      ultimately show ?thesis
        unfolding prems(7)[symmetric]
        by force
    qed
    done
  ultimately show ?thesis ..
qed

lemma poincare_map_has_derivative_step:
  assumes Deriv: "(poincare_map P has_derivative blinfun_apply D) (at (flow0 x0 h))"
  assumes ret: "returns_to P x0"
  assumes cont: "continuous (at x0 within S) (return_time P)"
  assumes less: "0 \<le> h" "h < return_time P x0"
  assumes cP: "closed P" and x0: "x0 \<in> S"
  shows "((\<lambda>x. poincare_map P x) has_derivative (D o\<^sub>L Dflow x0 h)) (at x0 within S)"
proof (rule has_derivative_transform_eventually)
  note return_time_tendsto = cont[unfolded continuous_within, rule_format]
  have "return_time P x0 \<in> existence_ivl0 x0"
    by (auto intro!: return_time_exivl cP ret)
  from ivl_subset_existence_ivl[OF this] less
  have hex: "h \<in> existence_ivl0 x0" by auto
  from eventually_mem_existence_ivl[OF this]
  have "\<forall>\<^sub>F x in at x0 within S. h \<in> existence_ivl0 x"
    by (auto simp: eventually_at)
  moreover
  have "\<forall>\<^sub>F x in at x0 within S. h < return_time P x"
    apply (rule order_tendstoD)
     apply (rule return_time_tendsto)
    by (auto intro!: x0 less)
  moreover have evret: "eventually (returns_to P) (at x0 within S)"
    by (rule eventually_returns_to_continuousI; fact)
  ultimately
  show "\<forall>\<^sub>F x in at x0 within S. poincare_map P (flow0 x h) = poincare_map P x"
    apply eventually_elim
    apply (cases "h = 0")
    subgoal by auto
    subgoal for x
      apply (rule poincare_map_step_flow)
      using \<open>0 \<le> h\<close> return_time_least[of P x ]
      by (auto simp: \<open>closed P\<close>)
    done
  show "poincare_map P (flow0 x0 h) = poincare_map P x0"
    using less ret x0 cP hex
    apply (cases "h = 0")
    subgoal by auto
    subgoal
      apply (rule poincare_map_step_flow)
      using \<open>0 \<le> h\<close> return_time_least[of P x0] ret
      by (auto simp: \<open>closed P\<close>)
    done
  show "x0 \<in> S" by fact
  show "((\<lambda>x. poincare_map P (flow0 x h)) has_derivative blinfun_apply (D o\<^sub>L Dflow x0 h)) (at x0 within S)"
    apply (rule has_derivative_compose[where g="poincare_map P" and f="\<lambda>x. flow0 x h", OF _ Deriv,
        THEN has_derivative_eq_rhs])
    by (auto intro!: derivative_eq_intros simp: hex flowderiv_def)
qed

lemma poincare_mapsto_trans:
  assumes "poincare_mapsto p1 X0 S    CX P1"
  assumes "poincare_mapsto p2 P1 UNIV CY P2"
  assumes "CX \<union> CY \<union> fst ` P1 \<subseteq> CZ"
  assumes "p2 \<inter> (CX \<union> fst ` P1) = {}"
  assumes [intro, simp]: "closed p1"
  assumes [intro, simp]: "closed p2"
  assumes cont: "\<And>x d. (x, d) \<in> X0 \<Longrightarrow> continuous (at x within S) (return_time p2)"
  shows "poincare_mapsto p2 X0 S CZ P2"
  unfolding poincare_mapsto_def
proof (auto, goal_cases)
  fix x0 d0 assume x0: "(x0, d0) \<in> X0"
  from assms(1) x0 obtain D1 dR1 where 1:
    "returns_to p1 x0"
    "fst ` X0 \<subseteq> S"
    "(return_time p1 has_derivative dR1) (at x0 within S)"
    "(poincare_map p1 has_derivative blinfun_apply D1) (at x0 within S)"
    "(poincare_map p1 x0, D1 o\<^sub>L d0) \<in> P1"
    "\<And>t. 0 < t \<Longrightarrow> t < return_time p1 x0 \<Longrightarrow> flow0 x0 t \<in> CX"
    by (auto simp: poincare_mapsto_def differentiable_def)
  then have crt1: "continuous (at x0 within S) (return_time p1)"
    by (auto intro!: has_derivative_continuous)
  show "x0 \<in> S"
    using 1 x0 by auto
  let ?x0 = "poincare_map p1 x0"
  from assms(2) x0 \<open>_ \<in> P1\<close>
  obtain D2 dR2 where 2:
    "returns_to p2 ?x0"
    "(return_time p2 has_derivative dR2) (at ?x0)"
    "(poincare_map p2 has_derivative blinfun_apply D2) (at ?x0)"
    "(poincare_map p2 ?x0, D2 o\<^sub>L (D1 o\<^sub>L d0)) \<in> P2"
    "\<And>t. t\<in>{0<..<return_time p2 ?x0} \<Longrightarrow> flow0 ?x0 t \<in> CY"
    by (auto simp: poincare_mapsto_def differentiable_def)

  have "\<forall>\<^sub>F t in at_right 0. t < return_time p1 x0"
    by (rule order_tendstoD) (auto intro!: return_time_pos 1)
  moreover have "\<forall>\<^sub>F t in at_right 0. 0 < t"
    by (auto simp: eventually_at_filter)
  ultimately have evnotp2: "\<forall>\<^sub>F t in at_right 0. flow0 x0 t \<notin> p2"
    by eventually_elim (use assms 1 in auto)
  from 2(1)
  show ret2: "returns_to p2 x0"
    unfolding poincare_map_def
    by (rule returns_to_earlierI)
       (use evnotp2 in \<open>auto intro!: less_imp_le return_time_pos 1 return_time_exivl\<close>)
  have not_p2: "0 < t \<Longrightarrow> t \<le> return_time p1 x0 \<Longrightarrow> flow0 x0 t \<notin> p2" for t
    using 1(5) 1(6)[of t] assms(4)
    by (force simp: poincare_map_def set_eq_iff)
  have pm_eq: "poincare_map p2 x0 = poincare_map p2 (poincare_map p1 x0)"
    using not_p2
    apply (auto simp: poincare_map_def)
    apply (subst flow_trans[symmetric])
      apply (auto intro!: return_time_exivl 1 2[unfolded poincare_map_def])
    apply (subst return_time_step)
    by (auto simp: return_time_step
        intro!: return_time_exivl 1 2[unfolded poincare_map_def] return_time_pos)

  have evret2: "\<forall>\<^sub>F x in at ?x0. returns_to p2 x"
    by (auto intro!: eventually_returns_to_continuousI 2 has_derivative_continuous)

  have evret1: "\<forall>\<^sub>F x in at x0 within S. returns_to p1 x"
    by (auto intro!: eventually_returns_to_continuousI 1 has_derivative_continuous)
  moreover
  from evret2[unfolded eventually_at_topological] 2(1)
  obtain U where U: "open U" "poincare_map p1 x0 \<in> U" "\<And>x. x \<in> U \<Longrightarrow> returns_to p2 x"
    by force
  have "continuous (at x0 within S) (poincare_map p1)"
    by (rule has_derivative_continuous) (rule 1)
  note [tendsto_intros] = this[unfolded continuous_within]
  have "eventually (\<lambda>x. poincare_map p1 x \<in> U) (at x0 within S)"
    by (rule topological_tendstoD) (auto intro!: tendsto_eq_intros U)
  then have evret_flow: "\<forall>\<^sub>F x in at x0 within S. returns_to p2 (flow0 x (return_time p1 x))"
    unfolding poincare_map_def[symmetric]
    apply eventually_elim
    apply (rule U)
    apply auto
    done
  moreover
  have h_less_rt: "return_time p1 x0 < return_time p2 x0"
    by (rule return_time_gt; fact)
  then have "0 < return_time p2 x0 - return_time p1 x0"
    by (simp )
  from _ this have "\<forall>\<^sub>F x in at x0 within S. 0 < return_time p2 x - return_time p1 x"
    apply (rule order_tendstoD)
    using cont \<open>(x0, _) \<in> _\<close>
    by (auto intro!: tendsto_eq_intros crt1 simp: continuous_within[symmetric] continuous_on_def)
  then have evpm2: "\<forall>\<^sub>F x in at x0 within S. \<forall>s. 0 < s \<longrightarrow> s \<le> return_time p1 x \<longrightarrow> flow0 x s \<notin> p2"
    apply eventually_elim
    apply safe
    subgoal for x s
      using return_time_least[of p2 x s]
      by (auto simp add: return_time_pos_returns_to)
    done
  ultimately
  have pm_eq_at: "\<forall>\<^sub>F x in at x0 within S.
    poincare_map p2 (poincare_map p1 x) = poincare_map p2 x"
    apply (eventually_elim)
    apply (auto simp: poincare_map_def)
    apply (subst flow_trans[symmetric])
      apply (auto intro!: return_time_exivl)
    apply (subst return_time_step)
    by (auto simp: return_time_step
        intro!: return_time_exivl return_time_pos)
  from _ this have "(poincare_map p2 has_derivative blinfun_apply (D2 o\<^sub>L D1)) (at x0 within S)"
    apply (rule has_derivative_transform_eventually)
      apply (rule has_derivative_compose[OF 1(4) 2(3), THEN has_derivative_eq_rhs])
    by (auto simp: \<open>x0 \<in> S\<close> pm_eq)
  moreover have "(poincare_map p2 x0, (D2 o\<^sub>L D1) o\<^sub>L d0) \<in> P2"
    using 2(4) unfolding pm_eq blinfun_compose_assoc .
  ultimately
  show "\<exists>D. (poincare_map p2 has_derivative blinfun_apply D) (at x0 within S) \<and>
               (poincare_map p2 x0, D o\<^sub>L d0) \<in> P2"
    by auto
  show "0 < t \<Longrightarrow> t < return_time p2 x0 \<Longrightarrow> flow0 x0 t \<in> CZ" for t
    apply (cases "t < return_time p1 x0")
    subgoal
      apply (drule 1)
      using assms
      by auto
    subgoal
      apply (cases "t = return_time p1 x0")
      subgoal using 1(5) assms by (auto simp: poincare_map_def)
      subgoal premises prems
      proof -
        have "flow0 x0 t = flow0 ?x0 (t - return_time p1 x0)"
          unfolding poincare_map_def
          apply (subst flow_trans[symmetric])
          using prems
          by (auto simp:
              intro!: return_time_exivl 1 diff_existence_ivl_trans
              less_return_time_imp_exivl[OF _ ret2])
        also have "\<dots> \<in> CY"
          apply (rule 2)
          using prems
          apply auto
          using "1"(1) "2"(1) assms poincare_map_def ret2 return_time_exivl
            return_time_least return_time_pos return_time_step
          by auto
        also have "\<dots> \<subseteq> CZ" using assms by auto
        finally show "flow0 x0 t \<in> CZ"
          by simp
      qed
      done
    done
  have rt_eq: "return_time p2 (poincare_map p1 x0) + return_time p1 x0 = return_time p2 x0"
    apply (auto simp: poincare_map_def)
    apply (subst return_time_step)
    by (auto simp: return_time_step poincare_map_def[symmetric] not_p2
        intro!: return_time_exivl return_time_pos 1 2)
  have evrt_eq: "\<forall>\<^sub>F x in at x0 within S.
    return_time p2 (poincare_map p1 x) + return_time p1 x = return_time p2 x"
    using evret_flow evret1 evpm2
    apply (eventually_elim)
    apply (auto simp: poincare_map_def)
    apply (subst return_time_step)
    by (auto simp: return_time_step
        intro!: return_time_exivl return_time_pos)
  from _ evrt_eq
  have "(return_time p2 has_derivative (\<lambda>x. dR2 (blinfun_apply D1 x) + dR1 x)) (at x0 within S)"
    by (rule has_derivative_transform_eventually)
      (auto intro!: derivative_eq_intros has_derivative_compose[OF 1(4) 2(2)] 1(3) \<open>x0 \<in> S\<close>
        simp: rt_eq)
  then show "return_time p2 differentiable at x0 within S" by (auto intro!: differentiableI)
qed

lemma flowsto_poincare_trans:\<comment> \<open>TODO: the proof is close to @{thm poincare_mapsto_trans}\<close>
  assumes f: "flowsto            X0 T     CX P1"
  assumes "poincare_mapsto p2 P1 UNIV CY P2"
  assumes nn: "\<And>t. t \<in> T \<Longrightarrow> t \<ge> 0"
  assumes "fst ` CX \<union> CY \<union> fst ` P1 \<subseteq> CZ"
  assumes "p2 \<inter> (fst ` CX \<union> fst ` P1) = {}"
  assumes [intro, simp]: "closed p2"
  assumes cont: "\<And>x d. (x, d) \<in> X0 \<Longrightarrow> continuous (at x within S) (return_time p2)"
  assumes subset: "fst ` X0 \<subseteq> S"
  shows "poincare_mapsto p2 X0 S CZ P2"
  unfolding poincare_mapsto_def
proof (auto, goal_cases)
  fix x0 d0 assume x0: "(x0, d0) \<in> X0"
  from flowstoE[OF f x0] obtain h where 1:
    "h \<in> T" "h \<in> existence_ivl0 x0"
    "(flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> P1" (is "(?x0, _) \<in> _")
    "(\<And>h'. h' \<in> {0<--<h} \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX)"
    by auto
  then have CX: "(\<And>h'. 0 < h' \<Longrightarrow> h' < h \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX)"
    by (auto simp: nn open_segment_eq_real_ivl)
  from 1 have "0 \<le> h" by (auto simp: nn)
  from assms have CX_p2D: "x \<in> CX \<Longrightarrow> fst x \<notin> p2" for x by auto
  from assms have P1_p2D: "x \<in> P1 \<Longrightarrow> fst x \<notin> p2" for x by auto
  show "x0 \<in> S"
    using x0 1 subset by auto
  let ?D1 = "Dflow x0 h"
  from assms(2) x0 \<open>_ \<in> P1\<close>
  obtain D2 dR2 where 2:
    "returns_to p2 ?x0"
    "(return_time p2 has_derivative dR2) (at ?x0)"
    "(poincare_map p2 has_derivative blinfun_apply D2) (at ?x0)"
    "(poincare_map p2 ?x0, D2 o\<^sub>L (?D1 o\<^sub>L d0)) \<in> P2"
    "\<And>t. t\<in>{0<..<return_time p2 ?x0} \<Longrightarrow> flow0 ?x0 t \<in> CY"
    by (auto simp: poincare_mapsto_def differentiable_def)

  {
    assume pos: "h > 0"
    have "\<forall>\<^sub>F t in at_right 0. t < h"
      by (rule order_tendstoD) (auto intro!: return_time_pos 1 pos)
    moreover have "\<forall>\<^sub>F t in at_right 0. 0 < t"
      by (auto simp: eventually_at_filter)
    ultimately have "\<forall>\<^sub>F t in at_right 0. flow0 x0 t \<notin> p2"
      by eventually_elim (use assms in \<open>force dest: CX CX_p2D\<close>)
  } note evnotp2 = this
  from 2(1)
  show ret2: "returns_to p2 x0"
    apply (cases "h = 0")
    subgoal using 1 by auto
    unfolding poincare_map_def
    by (rule returns_to_earlierI)
       (use evnotp2 \<open>0 \<le> h\<close> in \<open>auto intro!: less_imp_le return_time_pos 1 return_time_exivl \<close>)
  have not_p2: "0 < t \<Longrightarrow> t \<le> h \<Longrightarrow> flow0 x0 t \<notin> p2" for t
    using 1(1-3) CX[of t] assms(4) CX_p2D P1_p2D
    by (cases "h = t") (auto simp: poincare_map_def set_eq_iff subset_iff)
  have pm_eq: "poincare_map p2 x0 = poincare_map p2 ?x0"
    apply (cases "h = 0", use 1 in force)
    using not_p2 \<open>0 \<le> h\<close>
    apply (auto simp: poincare_map_def)
    apply (subst flow_trans[symmetric])
      apply (auto intro!: return_time_exivl 1 2[unfolded poincare_map_def])
    apply (subst return_time_step)
    by (auto simp: return_time_step
        intro!: return_time_exivl 1 2[unfolded poincare_map_def] return_time_pos)

  have evret2: "\<forall>\<^sub>F x in at ?x0. returns_to p2 x"
    by (auto intro!: eventually_returns_to_continuousI 2 has_derivative_continuous)

  have "\<forall>\<^sub>F x in at x0. h \<in> existence_ivl0 x"
    by (simp add: 1 eventually_mem_existence_ivl)
  then have evex: "\<forall>\<^sub>F x in at x0 within S. h \<in> existence_ivl0 x"
    by (auto simp: eventually_at)
  moreover
  from evret2[unfolded eventually_at_topological] 2(1)
  obtain U where U: "open U" "flow0 x0 h \<in> U" "\<And>x. x \<in> U \<Longrightarrow> returns_to p2 x"
    by force
  note [tendsto_intros] = this[unfolded continuous_within]
  have "eventually (\<lambda>x. flow0 x h \<in> U) (at x0 within S)"
    by (rule topological_tendstoD) (auto intro!: tendsto_eq_intros U 1)
  then have evret_flow: "\<forall>\<^sub>F x in at x0 within S. returns_to p2 (flow0 x h)"
    unfolding poincare_map_def[symmetric]
    apply eventually_elim
    apply (rule U)
    apply auto
    done
  moreover
  have h_less_rt: "h < return_time p2 x0"
    by (rule return_time_gt; fact)
  then have "0 < return_time p2 x0 - h"
    by (simp )
  from _ this have "\<forall>\<^sub>F x in at x0 within S. 0 < return_time p2 x - h"
    apply (rule order_tendstoD)
    using cont \<open>(x0, _) \<in> _\<close>
    by (auto intro!: tendsto_eq_intros simp: continuous_within[symmetric] continuous_on_def)
  then have evpm2: "\<forall>\<^sub>F x in at x0 within S. \<forall>s. 0 < s \<longrightarrow> s \<le> h \<longrightarrow> flow0 x s \<notin> p2"
    apply eventually_elim
    apply safe
    subgoal for x s
      using return_time_least[of p2 x s]
      by (auto simp add: return_time_pos_returns_to)
    done
  ultimately
  have pm_eq_at: "\<forall>\<^sub>F x in at x0 within S.
    poincare_map p2 (flow0 x h) = poincare_map p2 x"
    apply (eventually_elim)
    apply (cases "h = 0") subgoal by auto
    apply (auto simp: poincare_map_def)
    apply (subst flow_trans[symmetric])
      apply (auto intro!: return_time_exivl)
    apply (subst return_time_step)
    using \<open>0 \<le> h\<close>
    by (auto simp: return_time_step intro!: return_time_exivl return_time_pos)
  from _ this have "(poincare_map p2 has_derivative blinfun_apply (D2 o\<^sub>L ?D1)) (at x0 within S)"
    apply (rule has_derivative_transform_eventually)
    apply (rule has_derivative_at_withinI)
    apply (rule has_derivative_compose[OF flow_has_space_derivative 2(3), THEN has_derivative_eq_rhs])
    by (auto simp: \<open>x0 \<in> S\<close> pm_eq 1)
  moreover have "(poincare_map p2 x0, (D2 o\<^sub>L ?D1) o\<^sub>L d0) \<in> P2"
    using 2(4) unfolding pm_eq blinfun_compose_assoc .
  ultimately
  show "\<exists>D. (poincare_map p2 has_derivative blinfun_apply D) (at x0 within S) \<and>
               (poincare_map p2 x0, D o\<^sub>L d0) \<in> P2"
    by auto
  show "0 < t \<Longrightarrow> t < return_time p2 x0 \<Longrightarrow> flow0 x0 t \<in> CZ" for t
    apply (cases "t < h")
    subgoal
      apply (drule CX)
      using assms
      by auto
    subgoal
      apply (cases "t = h")
      subgoal using 1 assms by (auto simp: poincare_map_def)
      subgoal premises prems
      proof -
        have "flow0 x0 t = flow0 ?x0 (t - h)"
          unfolding poincare_map_def
          apply (subst flow_trans[symmetric])
          using prems
          by (auto simp:
              intro!: return_time_exivl 1 diff_existence_ivl_trans
              less_return_time_imp_exivl[OF _ ret2])
        also have "\<dots> \<in> CY"
          apply (cases "h = 0")
          subgoal using "1"(2) "2"(5) prems(1) prems(2) by auto
          subgoal
            apply (rule 2)
            using prems
            apply auto
            apply (subst return_time_step)
                 apply (rule returns_to_laterI)
            using ret2 \<open>0 \<le> h\<close> \<open>h \<in> existence_ivl0 x0\<close> not_p2
            by auto
          done
          also have "\<dots> \<subseteq> CZ" using assms by auto
        finally show "flow0 x0 t \<in> CZ"
          by simp
      qed
      done
    done
  have rt_eq: "return_time p2 ?x0 + h = return_time p2 x0"
    apply (cases "h = 0")
    subgoal using 1 by auto
    subgoal
      apply (subst return_time_step)
      using \<open>0 \<le> h\<close>
      by (auto simp: return_time_step poincare_map_def[symmetric] not_p2
          intro!: return_time_exivl return_time_pos 1 2)
    done
  have evrt_eq: "\<forall>\<^sub>F x in at x0 within S.
    return_time p2 (flow0 x h) + h = return_time p2 x"
    using evret_flow evpm2 evex
    apply (eventually_elim)
    apply (cases "h = 0")
    subgoal using 1 by auto
    subgoal
      apply (subst return_time_step)
      using \<open>0 \<le> h\<close>
      by (auto simp: return_time_step
          intro!: return_time_exivl return_time_pos)
    done
  from _ evrt_eq
  have "(return_time p2 has_derivative (\<lambda>x. dR2 (blinfun_apply ?D1 x))) (at x0 within S)"
    apply (rule has_derivative_transform_eventually)
      apply (rule has_derivative_at_withinI)
    by (auto intro!: derivative_eq_intros has_derivative_compose[OF flow_has_space_derivative 2(2)] 1 \<open>x0 \<in> S\<close>
        simp: rt_eq)
  then show "return_time p2 differentiable at x0 within S" by (auto intro!: differentiableI)
qed

subsection \<open>conditions for continuous return time\<close>

definition "section s Ds S \<longleftrightarrow>
  (\<forall>x. (s has_derivative blinfun_apply (Ds x)) (at x)) \<and>
  (\<forall>x. isCont Ds x) \<and>
  (\<forall>x \<in> S. s x = (0::real) \<longrightarrow> Ds x (f x) \<noteq> 0) \<and>
  closed S \<and> S \<subseteq> X"

lemma sectionD:
  assumes "section s Ds S"
  shows "(s has_derivative blinfun_apply (Ds x)) (at x)"
    "isCont Ds x"
    "x \<in> S \<Longrightarrow> s x = 0 \<Longrightarrow> Ds x (f x) \<noteq> 0"
    "closed S" "S \<subseteq> X"
  using assms by (auto simp: section_def)

definition "transversal p \<longleftrightarrow> (\<forall>x \<in> p. \<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> p)"

lemma transversalD: "transversal p \<Longrightarrow> x \<in> p \<Longrightarrow> \<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> p"
  by (auto simp: transversal_def)

lemma transversal_section:
  fixes c::real
  assumes "section s Ds S"
  shows "transversal {x \<in> S. s x = 0}"
  using assms
  unfolding section_def transversal_def
proof (safe, goal_cases)
  case (1 x)
  then have "x \<in> X" by auto
  have "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> {xa \<in> S. s xa = 0}"
    by (rule flow_avoids_surface_eventually_at_right)
      (rule disjI2 assms 1[rule_format] refl \<open>x \<in> X\<close>)+
  then show ?case
    by simp
qed

lemma section_closed[intro, simp]: "section s Ds S \<Longrightarrow> closed {x \<in> S. s x = 0}"
  by (auto intro!: closed_levelset_within simp: section_def
      intro!: has_derivative_continuous_on has_derivative_at_withinI[where s=S])

lemma return_time_continuous_belowI:
  assumes ft: "flowsto X0 T CX X1"
  assumes pos: "\<And>t. t \<in> T \<Longrightarrow> t > 0"
  assumes X0: "fst ` X0 \<subseteq> {x \<in> S. s x = 0}"
  assumes CX: "fst ` CX \<inter> {x \<in> S. s x = 0} = {}"
  assumes X1: "fst ` X1 \<subseteq> {x \<in> S. s x = 0}"
  assumes sec: "section s Ds S"
  assumes nz: "\<And>x. x \<in> S \<Longrightarrow> s x = 0 \<Longrightarrow> Ds x (f x) \<noteq> 0"
  assumes Dneg: "(\<lambda>x. (Ds x) (f x)) ` fst ` X0 \<subseteq> {..<0}"
  assumes rel_int: "\<And>x. x \<in> fst ` X1 \<Longrightarrow> \<forall>\<^sub>F x in at x. s x = 0 \<longrightarrow> x \<in> S"
  assumes "(x, d) \<in> X0"
  shows "continuous (at x within {x. s x \<le> 0}) (return_time {x \<in> S. s x = 0})"
proof (rule return_time_continuous_below)
  from assms have "x \<in> S" "s x = 0" "x \<in> {x \<in> S. s x = 0}" by auto
  note cs = section_closed[OF sec]
  note sectionD[OF sec]
  from flowstoE[OF ft \<open>(x, d) \<in> X0\<close>] obtain h
    where h: "h \<in> T"
      "h \<in> existence_ivl0 x"
      "(flow0 x h, Dflow x h o\<^sub>L d) \<in> X1"
      "(\<And>h'. h' \<in> {0<--<h} \<Longrightarrow> (flow0 x h', Dflow x h' o\<^sub>L d) \<in> CX)"
    by blast
  show ret: "returns_to {x \<in> S. s x = 0} x"
    apply (rule returns_toI)
        apply (rule pos)
        apply (rule h)
    subgoal by (rule h)
    subgoal using h(3) X1 by auto
    subgoal apply (intro transversalD) apply (rule transversal_section) apply (rule sec)
      apply fact
      done
    subgoal by fact
    done
  show "(s has_derivative blinfun_apply (Ds x)) (at x)" for x by fact
  show "closed S" by fact
  show "isCont Ds x" for x by fact
  show "x \<in> S" "s x = 0" by fact+
  let ?p = "poincare_map {x \<in> S. s x = 0} x"
  have "?p \<in> {x \<in> S. s x = 0}" using poincare_map_returns[OF ret cs] .
  with nz show "Ds ?p (f ?p) \<noteq> 0" by auto
  from Dneg \<open>(x, _) \<in> X0\<close> show "Ds x (f x) < 0" by force
  from \<open>_ \<in> X1\<close> X1 CX h
  have "return_time {x \<in> S. s x = 0} x = h"
    by (fastforce intro!: return_time_eqI cs pos h simp: open_segment_eq_real_ivl)
  then have "?p \<in> fst ` X1"
    using \<open>_ \<in> X1\<close> by (force simp: poincare_map_def)
  from rel_int[OF this] show " \<forall>\<^sub>F x in at (poincare_map {x \<in> S. s x = 0} x). s x = 0 \<longrightarrow> x \<in> S"
    by auto
qed

end

end


theory ExtendedDDL                    (*David Fuenmayor and C. Benzmüller, 2019*)
  imports CJDDLplus
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Extending the Carmo and Jones DDL Logical Framework\<close>

subsection \<open>Context Features\<close>

(**To keep things simple (and relevant for our task) we restrict ourselves to representing a context c as the pair: @{text "\<langle>Agent(c), World(c)\<rangle>"}.
For this purpose we represent the functional concepts "Agent" and "World" as logical constants.*)
consts Agent::"c\<Rightarrow>e"  (**function retrieving the agent corresponding to context c*)
consts World::"c\<Rightarrow>w"  (**function retrieving the world corresponding to context c*)

subsection \<open>Logical Validity\<close>

(**Kaplan's notion of (context-dependent) logical truth for a sentence corresponds to its (context-sensitive) formula
(of type @{text "c\<Rightarrow>w\<Rightarrow>bool"} i.e. m) being true in the given context and at its corresponding world.*)
abbreviation ldtruectx::"m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>_") where "\<lfloor>\<phi>\<rfloor>\<^sub>c \<equiv> \<phi> c (World c)"

(**Kaplan's LD notion of logical validity for a sentence corresponds to its being true in all contexts.
This notion is also known as indexical validity.*)
abbreviation ldvalid::"m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>D") where "\<lfloor>\<phi>\<rfloor>\<^sup>D \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sub>c"

(**Here we show that indexical validity is indeed weaker than its classical modal counterpart (truth at all worlds for all contexts):*)
lemma "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>A\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>A\<rfloor>" nitpick oops (**countermodel found*)

(**Here we show that the interplay between indexical validity and the DDL modal and deontic operators does not
result in modal collapse.*)
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>\<^sup>D" nitpick oops
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>\<^sup>D" nitpick oops

(**Next we show that the necessitation rule does not work for indexical validity (in contrast to classical modal validity as defined for DDL).*)
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>\<^sup>D"  nitpick oops
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>\<^sup>D" nitpick oops

(**The following operator above is not part of the original Kaplan's LD and has been added
by us in order to better highlight some semantic features of our formalisation of Gewirth's argument in the next section and to being able to
use the necessitation rule for some inference steps. This is used to model a kind of logical-indexical necessity in contrast
to the alethic necessity shown above.*)
abbreviation ldvalidbox :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>D_" [52]53) where "\<^bold>\<box>\<^sup>D\<phi> \<equiv> \<lambda>c w. \<lfloor>\<phi>\<rfloor>\<^sup>D" (**note the D superscript*)
lemma "\<lfloor>\<^bold>\<box>\<^sup>D\<phi>\<rfloor>\<^sub>C \<equiv> \<forall>c.\<lfloor>\<phi>\<rfloor>\<^sub>c" by simp (**works analogously to the box operator in modal logic S5*)

(**The necessitation rule works for the combination of indexical validity with the previous operator, as intended.*)
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sup>DA\<rfloor>\<^sup>D"  by simp

subsection \<open>Quantification\<close>
(** We also enrich our logic with (higher-order) quantifiers (using parameterized types).*)
abbreviation mforall::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>c w.\<forall>x. (\<Phi> x c w)"
abbreviation mexists::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>c w.\<exists>x. (\<Phi> x c w)"
abbreviation mforallBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"

(*<*)
end
(*>*)


(*<*)
theory Infinite_Proof_Soundness
imports Finite_Proof_Soundness "~~/src/HOL/Library/BNF_Corec"
begin

(* Reference: A Generic Cyclic Theorem Prover
by James Brotherston, Nikos Gorogiannis, and Rasmus L. Petersen
*)
(*>*)

section \<open>Soundness of Infinite Proof Trees\<close>

context
begin

private definition "num P xs \<equiv> LEAST n. list_all (Not o P) (stake n xs) \<and> P (xs!!n)"

private lemma num:
  assumes ev: "ev (\<lambda>xs. P (shd xs)) xs"
  defines "n \<equiv> num P xs"
  shows
    "(list_all (Not o P) (stake n xs) \<and> P (xs!!n)) \<and>
 (\<forall>m. list_all (Not o P) (stake m xs) \<and> P (xs!!m) \<longrightarrow> n \<le> m)"
  unfolding n_def num_def
proof (intro conjI[OF LeastI_ex] allI impI Least_le)
  from ev show "\<exists>n. list_all (Not o P) (stake n xs) \<and> P (xs !! n)"
    by (induct rule: ev_induct_strong) (auto intro: exI[of _ 0] exI[of _ "Suc _"])
qed (simp_all add: o_def)

private lemma num_stl[simp]:
  assumes "ev (\<lambda>xs. P (shd xs)) xs" and "\<not> P (shd xs)"
  shows "num P xs = Suc (num P (stl xs))"
  unfolding num_def by (rule trans[OF Least_Suc[of _ "num P xs"]])
    (auto simp: num[OF assms(1)] assms(2))

corecursive decr0 where
  "decr0 Ord minSoFar js =
    (if \<not> (ev (\<lambda>js. (shd js, minSoFar) \<in> Ord \<and> shd js \<noteq> minSoFar)) js
     then undefined
     else if ((shd js, minSoFar) \<in> Ord \<and> shd js \<noteq> minSoFar)
          then shd js ## decr0 Ord (shd js) js
          else decr0 Ord minSoFar (stl js))"
  by (relation "measure (\<lambda>(Ord,m,js). num (\<lambda>j. (j, m) \<in> Ord \<and> j \<noteq> m) js)") auto

end

lemmas well_order_on_defs =
  well_order_on_def linear_order_on_def partial_order_on_def
  preorder_on_def trans_def antisym_def refl_on_def

lemma sdrop_length_shift[simp]:
  "sdrop (length xs) (xs @- s) = s"
  by (simp add: sdrop_shift)

lemma ev_iff_shift:
  "ev \<phi> xs \<longleftrightarrow> (\<exists>xl xs2. xs = xl @- xs2 \<and> \<phi> xs2)"
  by (meson ev.base ev_imp_shift ev_shift)

locale Infinite_Soundness = RuleSystem_Defs eff rules for
  eff :: "'rule \<Rightarrow> 'sequent \<Rightarrow> 'sequent fset \<Rightarrow> bool"
  and rules :: "'rule stream"
  +
  fixes "structure" :: "'structure set"
    and sat :: "'structure \<Rightarrow> 'sequent \<Rightarrow> bool"
    and \<delta> :: "'sequent \<Rightarrow> 'rule \<Rightarrow> 'sequent \<Rightarrow> ('marker \<times> bool \<times> 'marker) set"
    and Ord :: "'ord rel"
    and \<sigma> :: "'marker \<times> 'structure \<Rightarrow> 'ord"
  assumes
    Ord: "well_order Ord"
    and
    descent: (* The original paper has an error in stating this: quantifies existentially
  instead of universally over r *)
    "\<And>r s sl S.
      \<lbrakk>r \<in> R; eff r s sl; S \<in> structure; \<not> sat S s\<rbrakk>
      \<Longrightarrow>
      \<exists>s' S'.
        s' |\<in>| sl \<and> S' \<in> structure \<and> \<not> sat S' s' \<and>
        (\<forall>v v' b.
          (v,b,v') \<in> \<delta> s r s' \<longrightarrow>
             (\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S)))"

(* The descent property subsumes local_soundness: *)
sublocale Infinite_Soundness < Soundness where eff = eff and rules = rules
  and "structure" = "structure" and sat = sat
  by standard (blast dest: descent)

context Infinite_Soundness
begin

(* The notion of a trace of markers following a path: to make the original paper definition
into a rigorous one, we include the trace of "progressing bits" as well:  *)
coinductive follow :: "bool stream \<Rightarrow> 'marker stream \<Rightarrow> ('sequent,'rule)step stream \<Rightarrow> bool" where
  "\<lbrakk>M' = shd Ms; s' = fst (shd steps); (M,b,M') \<in> \<delta> s r s'; follow bs Ms steps\<rbrakk>
 \<Longrightarrow>
 follow (SCons b bs) (SCons M Ms) (SCons (s,r) steps)"

(* Now infinite progress simply means "always eventually the bit is True": *)
definition infDecr :: "bool stream \<Rightarrow> bool" where
  "infDecr \<equiv> alw (ev (\<lambda>bs. shd bs))"

(* Good trees: *)
definition good :: "('sequent,'rule)dtree \<Rightarrow> bool" where
  "good t \<equiv> \<forall>steps.
  ipath t steps
  \<longrightarrow>
  ev (\<lambda>steps'. \<exists>bs Ms. follow bs Ms steps' \<and> infDecr bs) steps"
(* Note the mixture of temporal connectives and standard HOL quantifiers:
an advantage of the shallow embedding of LTL *)

(* Trivially, finite trees are particular cases of good trees, since they
have no infinite paths: *)
lemma tfinite_good: "tfinite t \<Longrightarrow> good t"
  using ftree_no_ipath unfolding good_def by auto

context
  fixes inv :: "'sequent \<times> 'a \<Rightarrow> bool"
    and pred :: "'sequent \<times> 'a \<Rightarrow> 'rule \<Rightarrow> 'sequent \<times> 'a \<Rightarrow> bool"
begin

primcorec konigDtree ::
  "('sequent,'rule) dtree \<Rightarrow> 'a \<Rightarrow> (('sequent,'rule) step \<times> 'a) stream" where
  "shd (konigDtree t a) = (root t, a)"
|"stl (konigDtree t a) =
  (let s = fst (root t); r = snd (root t);
   (s',a') = (SOME (s',a'). s' |\<in>| fimage (fst o root) (cont t) \<and> pred (s,a) r (s',a') \<and> inv (s',a'));
   t' = (SOME t'. t' |\<in>| cont t \<and> s' = fst (root t'))
   in konigDtree t' a'
  )"

lemma stl_konigDtree:
  fixes t defines "s \<equiv> fst (root t)" and "r \<equiv> snd (root t)"
  assumes s': "s' |\<in>| fimage (fst o root) (cont t)"  and "pred (s,a) r (s',a'')" and "inv (s',a'')"
  shows "\<exists>t' a'. t' |\<in>| cont t \<and> pred (s,a) r (fst (root t'),a') \<and> inv (fst (root t'),a')
  \<and> stl (konigDtree t a) = konigDtree t' a'"
proof-
  define P where "P \<equiv> \<lambda>(s',a'). s' |\<in>| fimage (fst o root) (cont t) \<and> pred (s,a) r (s',a') \<and> inv (s',a')"
  define s'a' where "s'a' \<equiv> SOME (s',a'). P (s',a')"  let ?s' = "fst s'a'"  let ?a' = "snd s'a'"
  define t' where "t' \<equiv> SOME (t'::('sequent,'rule)dtree). t' |\<in>| cont t \<and> ?s' = fst (root t')"
  have "P (s',a'')" using assms unfolding P_def by auto
  hence P: "P (?s',?a')" using someI[of P] unfolding s'a'_def by auto
  hence "\<exists>t'. t' |\<in>| cont t \<and> ?s' = fst (root t')" unfolding P_def by auto
  hence t': "t' |\<in>| cont t" and s': "?s' = fst (root t')"
    using someI_ex[of "\<lambda>t'. t' |\<in>| cont t \<and> ?s' = fst (root t')"] unfolding t'_def by auto
  show ?thesis using t' P s' assms P_def s'a'_def t'_def by (intro exI[of _ t'] exI[of _ ?a']) auto
qed

declare konigDtree.simps(2)[simp del]

lemma konigDtree:
  assumes 1: "\<And>r s sl a.
  \<lbrakk>r \<in> R; eff r s sl; inv (s,a)\<rbrakk> \<Longrightarrow>
  \<exists>s' a'. s' |\<in>| sl \<and> inv (s',a') \<and> pred (s,a) r (s',a')"
    and 2: "wf t" "inv (fst (root t), a)"
  shows
    "alw (\<lambda>stepas.
        let ((s,r),a) = shd stepas; ((s',_),a') = shd (stl stepas) in
          inv (s,a) \<and> pred (s,a) r (s',a'))
     (konigDtree t a)"
  using assms proof (coinduction arbitrary: t a)
  case (alw t a)
  then obtain s' a' where "s' |\<in>| (fst \<circ> root) |`| cont t" "inv (s', a')"
    "pred (fst (root t), a) (snd (root t)) (s', a')"
    by (auto elim!: wf.cases dest!: spec[of _ "snd (root t)"] spec[of _ "fst (root t)"]
        spec[of _ "(fst \<circ> root) |`| cont t"] spec[of _ a], fastforce)
  with alw stl_konigDtree[of s' t a a'] show ?case
    by (auto split: prod.splits elim!: wf.cases) fastforce
qed

lemma konigDtree_ipath:
  assumes "\<And>r s sl a.
  \<lbrakk>r \<in> R; eff r s sl; inv (s,a)\<rbrakk> \<Longrightarrow>
  \<exists>s' a'. s' |\<in>| sl \<and> inv (s',a') \<and> pred (s,a) r (s',a')"
    and "wf t" and "inv (fst (root t), a)"
  shows "ipath t (smap fst (konigDtree t a))"
  using assms proof (coinduction arbitrary: t a)
  case (ipath t a)
  then obtain s' a' where "s' |\<in>| (fst \<circ> root) |`| cont t" "inv (s', a')"
    "pred (fst (root t), a) (snd (root t)) (s', a')"
    by (auto elim!: wf.cases dest!: spec[of _ "snd (root t)"] spec[of _ "fst (root t)"]
        spec[of _ "(fst \<circ> root) |`| cont t"] spec[of _ a], fastforce)
  with ipath stl_konigDtree[of s' t a a'] show ?case
    by (auto split: prod.splits elim!: wf.cases) force
qed

end (* context *)

lemma follow_stl_smap_fst[simp]:
  "follow bs Ms (smap fst stepSs) \<Longrightarrow>
   follow (stl bs) (stl Ms) (smap fst (stl stepSs))"
  by (erule follow.cases) (auto simp del: stream.map_sel simp add: stream.map_sel[symmetric])

lemma epath_stl_smap_fst[simp]:
  "epath (smap fst stepSs) \<Longrightarrow>
   epath (smap fst (stl stepSs))"
  by (erule epath.cases) (auto simp del: stream.map_sel simp add: stream.map_sel[symmetric])

lemma infDecr_tl[simp]: "infDecr bs \<Longrightarrow> infDecr (stl bs)"
  unfolding infDecr_def by auto

(* Proof of the main theorem: *)
fun descent where "descent (s,S) r (s',S') =
 (\<forall>v v' b.
    (v,b,v') \<in> \<delta> s r s' \<longrightarrow>
    (\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S)))"

lemma descentE[elim]:
  assumes "descent (s,S) r (s',S')" and "(v,b,v') \<in> \<delta> s r s'"
  shows "(\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S))"
  using assms by auto

definition "konigDown \<equiv> konigDtree (\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s) descent"

lemma konigDown:
  assumes "wf t" and "S \<in> structure" and "\<not> sat S (fst (root t))"
  shows
    "alw (\<lambda>stepSs. let ((s,r),S) = shd stepSs; ((s',_),S') = shd (stl stepSs) in
                    S \<in> structure \<and> \<not> sat S s \<and> descent (s,S) r (s',S'))
     (konigDown t S)"
  using konigDtree[of "\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s" descent, unfolded konigDown_def[symmetric]]
  using assms descent by auto

lemma konigDown_ipath:
  assumes "wf t" and "S \<in> structure" and "\<not> sat S (fst (root t))"
  shows
    "ipath t (smap fst (konigDown t S))"
  using konigDtree_ipath[of "\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s" descent, unfolded konigDown_def[symmetric]]
  using assms descent by auto

context
  fixes t S
  assumes w: "wf t" and t: "good t" and S: "S \<in> structure" "\<not> sat S (fst (root t))"
begin

lemma alw_ev_Ord:
  obtains ks where "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks"
    and "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"
proof-
  define P where "P \<equiv> \<lambda>stepSs. let ((s,r),S) = shd stepSs; ((s',_),S') = shd (stl stepSs) in
                      S \<in> structure \<and> \<not> sat S s \<and> descent (s,S) r (s',S')"
  have "alw P (konigDown t S)" using konigDown[OF w S] unfolding P_def by auto
  obtain srs steps bs Ms where 0: "smap fst (konigDown t S) = srs @- steps" and
    f: "follow bs Ms steps" and i: "infDecr bs"
    using konigDown_ipath[OF w S] t unfolding good_def ev_iff_shift by auto
  define stepSs where "stepSs = sdrop (length srs) (konigDown t S)"
  have steps: "steps = smap fst stepSs" unfolding stepSs_def sdrop_smap[symmetric] 0 by simp
  have e: "epath steps"
    using wf_ipath_epath[OF w konigDown_ipath[OF w S]] 0 epath_shift by simp
  have "alw P (konigDown t S)" using konigDown[OF w S] unfolding P_def by auto
  hence P: "alw P stepSs" using alw_sdrop unfolding stepSs_def by auto
  let ?ks = "smap \<sigma> (szip Ms (smap snd stepSs))"
  show ?thesis proof(rule that[of ?ks])
    show "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ?ks"
      using e f P unfolding steps proof(coinduction arbitrary: bs Ms stepSs rule: alw_coinduct)
      case (alw bs Ms stepSs)
      let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
      let ?MSs = "szip Ms (smap snd stepSs)"
      let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
      let ?r = "snd (shd ?steps)"
      let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
      let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
      have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
        using `follow bs Ms (smap fst stepSs)` by (cases rule: follow.cases) auto
      have 2: "descent (?s,?S) ?r (?s',?S')"
        using `alw P stepSs` unfolding P_def by (cases rule: alw.cases) auto
      have "(\<sigma>(?M',?S'), \<sigma>(?M,?S)) \<in> Ord" using descentE[OF 2 1] by simp
      thus ?case by simp
    next
      case (stl bs Ms stepSs)
      thus ?case
        by (intro exI[of _ "stl bs"] exI[of _ "stl Ms"] exI[of _ "stl stepSs"])
          (auto elim: epath.cases)
    qed
  next
    show "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ?ks"
      using e f P i unfolding steps proof(coinduction arbitrary: bs Ms stepSs rule: alw_coinduct)
      case (alw bs Ms stepSs)
      let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
      let ?MSs = "szip Ms (smap snd stepSs)"
      let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
      let ?r = "snd (shd ?steps)"
      let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
      let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
      have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
        using `follow bs Ms (smap fst stepSs)` by (cases rule: follow.cases) auto
      have 2: "descent (?s,?S) ?r (?s',?S')"
        using `alw P stepSs` unfolding P_def by (cases rule: alw.cases) auto
      have "(\<sigma>(?M',?S'), \<sigma>(?M,?S)) \<in> Ord" using descentE[OF 2 1] by simp
      have "ev shd bs" using `infDecr bs` unfolding infDecr_def by auto
      thus ?case using `epath ?steps` `follow bs Ms ?steps` `alw P stepSs`
      proof (induction arbitrary: Ms stepSs)
        case (base bs Ms stepSs)
        let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
        let ?MSs = "szip Ms (smap snd stepSs)"
        let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
        let ?r = "snd (shd ?steps)"
        let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
        let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
        have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
          using `follow bs Ms (smap fst stepSs)` by (cases rule: follow.cases) auto
        have 2: "descent (?s,?S) ?r (?s',?S')"
          using `alw P stepSs` unfolding P_def by (cases rule: alw.cases) auto
        have "\<sigma>(?M',?S') \<noteq> \<sigma>(?M,?S)" using descentE[OF 2 1] `shd bs` by simp
        thus ?case by auto
      next
        case (step bs Ms stepSs)
        have "ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)
                  (smap \<sigma>
                  (szip (stl Ms) (smap snd (stl stepSs))))"
          using step(3-5) step(2)[of "stl stepSs" "stl Ms"] by auto
        thus ?case by auto
      qed
    next
      case (stl bs Ms stepSs)
      thus ?case
        by (intro exI[of _ "stl bs"] exI[of _ "stl Ms"] exI[of _ "stl stepSs"])
          (auto elim: epath.cases)
    qed
  qed
qed

definition
  "ks \<equiv> SOME ks.
        alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks \<and>
        alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"

lemma alw_ks: "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks"
  and alw_ev_ks: "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"
  unfolding ks_def using alw_ev_Ord someI_ex[of "\<lambda>ks.
        alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks \<and>
        alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"]
  by auto

abbreviation decr where "decr \<equiv> decr0 Ord"

lemmas decr_simps = decr0.code[of Ord]

context
  fixes js
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js"
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
begin

lemma decr_ev:
  assumes m: "(shd js, m) \<in> Ord"
  shows "ev (\<lambda>js. (shd js, m) \<in> Ord \<and> shd js \<noteq> m) js"
    (is "ev (\<lambda>js. ?\<phi> m js) js")
proof-
  have "ev (\<lambda>js. shd (stl js) \<noteq> shd js) js" using ae by auto
  thus ?thesis
    using a m proof induction
    case (base ls)
    hence "ev (?\<phi> (shd ls)) ls" by auto
    moreover have "\<And>js. ?\<phi> (shd ls) js \<Longrightarrow> ?\<phi> m js"
      using `(shd ls, m) \<in> Ord` Ord unfolding well_order_on_defs by blast
    ultimately show ?case using ev_mono[of "?\<phi> (shd ls)" _ "?\<phi> m"] by auto
  qed auto
qed

lemma decr_simps_diff[simp]:
  assumes m: "(shd js, m) \<in> Ord"
    and "shd js \<noteq> m"
  shows "decr m js = shd js ## decr (shd js) js"
  using decr_ev[OF m] assms by (subst decr_simps) simp

lemma decr_simps_eq[simp]:
  "decr (shd js) js = decr (shd js) (stl js)"
proof-
  have m: "(shd js, shd js) \<in> Ord" using Ord
    unfolding well_order_on_def linear_order_on_def partial_order_on_def
      preorder_on_def refl_on_def by auto
  show ?thesis using decr_ev[OF m] by (subst decr_simps) simp
qed

end (* context *)

lemma stl_decr:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js"
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
    and m: "(shd js, m) \<in> Ord"
  shows
    "\<exists>js1 js2. js = js1 @- js2 \<and> set js1 \<subseteq> {m} \<and>
 (shd js2, m) \<in> Ord \<and> shd js2 \<noteq> m \<and>
  shd (decr m js) = shd js2 \<and> stl (decr m js) = decr (shd js2) js2"
    (is "\<exists>js1 js2. ?\<phi> js js1 js2")
  using decr_ev[OF assms] m a ae proof (induction rule: ev_induct_strong)
  case (base js)
  thus ?case by  (intro exI[of _ "[]"] exI[of _ js]) auto
next
  case (step js)
  then obtain js1 js2 where 1: "?\<phi> (stl js) js1 js2" and [simp]: "shd js = m" by auto
  thus ?case
    by (intro exI[of _ "shd js # js1"] exI[of _ js2],
      simp, metis (lifting) decr_simps_eq step(2,4,5,6) stream.collapse)
qed

corollary stl_decr_shd:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js" and
    ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
  shows
    "\<exists>js1 js2. js = js1 @- js2 \<and> set js1 \<subseteq> {shd js} \<and>
 (shd js2, shd js) \<in> Ord \<and> shd js2 \<noteq> shd js \<and>
  shd (decr (shd js) js) = shd js2 \<and> stl (decr (shd js) js) = decr (shd js2) js2"
  using Ord unfolding well_order_on_defs by (intro stl_decr[OF assms]) blast

lemma decr:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js" (is "?a js")
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js" (is "?ae js")
  shows
    "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord \<and> shd (stl js) \<noteq> shd js) (decr (shd js) js)"
    (is "alw ?\<phi> _")
proof-
  let ?\<xi> = "\<lambda>ls js. ls = decr (shd js) js \<and> ?a js \<and> ?ae js"
  {fix ls assume "\<exists>js. ?\<xi> ls js"
    hence "alw ?\<phi> ls" proof(elim alw_coinduct)
      fix ls assume "\<exists>js. ?\<xi> ls js"
      then obtain js where 1: "?\<xi> ls js" by auto
      then obtain js1 js2 where js: "js = js1 @- js2 \<and> set js1 \<subseteq> {shd js} \<and>
       (shd js2, shd js) \<in> Ord \<and> shd js2 \<noteq> shd js \<and>
       shd ls = shd js2 \<and> stl ls = decr (shd js2) js2"
        using stl_decr_shd by blast
      then obtain js3 js4 where js2: "js2 = js3 @- js4 \<and> set js3 \<subseteq> {shd js2} \<and>
       (shd js4, shd js2) \<in> Ord \<and> shd js4 \<noteq> shd js2 \<and>
       shd (decr (shd js2) js2) = shd js4 \<and> stl ((decr (shd js2) js2)) = decr (shd js4) js4"
        using stl_decr_shd[of js2] a ae using 1 alw_shift by blast
      show "?\<phi> ls" using 1 js js2 by metis
    qed (metis (no_types, lifting) alw_shift stl_decr_shd)
  }
  thus ?thesis using assms by blast
qed

lemma alw_snth:
  assumes "alw (\<lambda>xs. P (shd (stl xs)) (shd xs)) xs"
  shows "P (xs!!(Suc n)) (xs!! n)"
  using assms
  by (induction n, auto, metis (mono_tags) alw.cases alw_iff_sdrop sdrop_simps(1) sdrop_stl)

lemma F: False
proof-
  define ls where "ls = decr (shd ks) ks"
  have 0: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord \<and> shd (stl js) \<noteq> shd js) ls"
    using decr[OF alw_ks alw_ev_ks] unfolding ls_def .
  define Q where "Q = range (snth ls)"  let ?wf = "Wellfounded.wf"
  have Q: "Q \<noteq> {}" unfolding Q_def by auto
  have 1: "?wf (Ord - Id)" using Ord unfolding well_order_on_def by auto
  obtain q where q: "q \<in> Q" and 2: "\<forall>q'. (q',q) \<in> Ord - Id \<longrightarrow> q' \<notin> Q"
    using wfE_min[OF 1] Q by auto
  obtain n where "ls!!n = q" using q unfolding Q_def by auto
  hence "(ls!!(Suc n),q) \<in> Ord - Id" using alw_snth[OF 0] by auto
  thus False using 2 Q_def by blast
qed

end (* context *)

(* Main theorem: *)
theorem infinite_soundness:
  assumes "wf t" and "good t" and "S \<in> structure"
  shows "sat S (fst (root t))"
  using F[OF assms] by auto

end (* context Infinite_Soundness *)

section \<open>Soundness of Cyclic Proof Trees\<close>

(* Cyclic trees *)

datatype (discs_sels) ('sequent, 'rule, 'link) ctree =
  Link 'link |
  cNode  "('sequent,'rule) step" "('sequent, 'rule, 'link) ctree fset"

corecursive treeOf where
  "treeOf pointsTo ct =
   (if \<exists>l l'. pointsTo l = Link l'
    (* makes sense only if backward links point to normal nodes, not to backwards links: *)
     then undefined
     else (case ct of
             Link l \<Rightarrow> treeOf pointsTo (pointsTo l)
            |cNode step cts \<Rightarrow> Node step (fimage (treeOf pointsTo) cts)
          )
   )"
  by (relation "measure (\<lambda>(p,t). case t of Link l' => Suc 0 | _ => 0)") (auto split: ctree.splits)

declare treeOf.code[simp]

context Infinite_Soundness
begin

context
  fixes pointsTo :: "'link \<Rightarrow> ('sequent, 'rule, 'link)ctree"
  assumes pointsTo: "\<forall>l l'. pointsTo l \<noteq> Link l'"
begin

function seqOf where
  "seqOf (Link l) = seqOf (pointsTo l)"
|
  "seqOf (cNode (s,r) _) = s"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>t. case t of Link l' => Suc 0 | _ => 0)")
    (auto split: ctree.splits simp: pointsTo)

    (* Note: Here, "inductive" instead of "coinductive" would not do! *)
coinductive cwf where
  Node[intro!]: "cwf (pointsTo l) \<Longrightarrow> cwf (Link l)"
|
  cNode[intro]:
  "\<lbrakk>r \<in> R; eff r s (fimage seqOf cts); \<And>ct'. ct' |\<in>| cts \<Longrightarrow> cwf ct'\<rbrakk>
\<Longrightarrow>
cwf (cNode (s,r) cts)"

definition "cgood ct \<equiv> good (treeOf pointsTo ct)"

lemma cwf_Link: "cwf (Link l) \<longleftrightarrow> cwf (pointsTo l)"
  by (auto elim: cwf.cases)

lemma cwf_cNode_seqOf:
  "cwf (cNode (s, r) cts) \<Longrightarrow> eff r s (fimage seqOf cts)"
  by (auto elim: cwf.cases)

lemma treeOf_seqOf[simp]:
  "fst \<circ> root \<circ> treeOf pointsTo = seqOf"
proof(rule ext, unfold o_def)
  fix ct show "fst (root (treeOf pointsTo ct)) = seqOf ct"
    by induct (auto split: ctree.splits simp: pointsTo)
qed

lemma wf_treeOf:
  assumes "cwf ct"
  shows "wf (treeOf pointsTo ct)"
proof-
  {fix t let ?\<phi> = "\<lambda>ct t. cwf ct \<and> t = treeOf pointsTo ct"
    assume "\<exists>ct. ?\<phi> ct t" hence "wf t"
    proof(elim wf.coinduct, safe)
      fix ct let ?t = "treeOf pointsTo ct"
      assume ct: "cwf ct"
      show "
       \<exists>t. treeOf pointsTo ct = t \<and>
           snd (root t) \<in> R \<and>
           effStep (root t) (fimage (fst \<circ> root) (cont t)) \<and>
           (\<forall>t'. t' |\<in>| cont t \<longrightarrow> (\<exists>ct'. ?\<phi> ct' t') \<or> wf t')"
      proof(rule exI[of _ ?t], safe)
        show "snd (root ?t) \<in> R" using pointsTo ct
          by (auto elim: cwf.cases split: ctree.splits simp: cwf_Link)
        show "effStep (root ?t) (fimage (fst \<circ> root) (cont ?t))"
          using pointsTo ct by (auto  elim: cwf.cases split: ctree.splits simp: cwf_Link)
        {fix t' assume t': "t' |\<in>| cont ?t"
          show "\<exists>ct'. ?\<phi> ct' t'"
          proof(cases ct)
            case (Link l)
            then obtain s r cts where pl: "pointsTo l = cNode (s,r) cts"
              using pointsTo by (cases "pointsTo l") auto
            obtain ct' where ct': "ct' |\<in>| cts" and "t' = treeOf pointsTo ct'"
              using t' by (auto simp: Link pl pointsTo split: ctree.splits)
            moreover have "cwf ct'" using ct' ct pl unfolding Link
              by (auto simp: cwf_Link elim: cwf.cases)
            ultimately show ?thesis by blast
          next
            case (cNode step cts)
            then obtain s r where cNode: "ct = cNode (s,r) cts" by (cases step) auto
            obtain ct' where ct': "ct' |\<in>| cts" and "t' = treeOf pointsTo ct'"
              using t' by (auto simp: cNode pointsTo split: ctree.splits)
            moreover have "cwf ct'" using ct' ct unfolding cNode
              by (auto simp: cwf_Link elim: cwf.cases)
            ultimately show ?thesis by blast
          qed
        }
      qed
    qed
  }
  thus ?thesis using assms by blast
qed

theorem cyclic_soundness:
  assumes "cwf ct" and "cgood ct" and "S \<in> structure"
  shows "sat S (seqOf ct)"
  using infinite_soundness wf_treeOf assms
  unfolding cgood_def treeOf_seqOf[symmetric] comp_def
  by blast

end (* context *)

end (* context Infinite_Soundness *)

section \<open>Appendix: The definition of treeOf under more flexible assumptions about pointsTo\<close>

definition rels where
  "rels pointsTo \<equiv> {((pointsTo, pointsTo l'), (pointsTo, Link l')) | l'. True}"

definition rel :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
  "rel \<equiv> UNION {pointsTo . wf {(l,l'). pointsTo l' = Link l}} rels"

lemma wf_rels[simp]:
  assumes "wf {(l,l'). (pointsTo :: 'link \<Rightarrow> ('sequent, 'rule, 'link)ctree) l' = Link l}"
    (is "wf ?w")
  shows "wf (rels pointsTo)" using wf_map_prod_image
proof -
  define r1 :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
    "r1 = {((pointsTo,pointsTo l'), (pointsTo, Link l'::('sequent, 'rule, 'link) ctree)) | l'.
                 (\<forall>l''. pointsTo l' \<noteq> Link l'')}"
  define r2 :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
    "r2 = image (map_prod (map_prod id Link) (map_prod id Link)) (inv_image ?w snd)"
  have 0: "rels pointsTo \<subseteq> r1 \<union> r2"
    unfolding rels_def r1_def r2_def unfolding inv_image_def image_Collect by auto
  let ?m = "measure (\<lambda>(tOfL,t). case t of Link l' => Suc 0 | _ => 0)"
  have 1: "wf r1" unfolding r1_def by (rule wf_subset[of ?m]) (auto split: ctree.splits)
  have 2: "wf r2" using assms unfolding r2_def
    by (intro wf_map_prod_image wf_inv_image) (auto simp: inj_on_def)
  have 3: "Domain r1 \<inter> Range r2 = {}" unfolding r1_def r2_def by auto
  show ?thesis using 1 2 3 by (intro wf_subset[OF _ 0] wf_Un) auto
qed

lemma rel: "wf rel"
  unfolding rel_def
  apply(rule wf_UN)
  subgoal by (auto intro: wf_UN)
  unfolding rels_def by auto

corecursive treeOf' where
  "treeOf' pointsTo ct =
   (if \<not> wf {(l',l).  pointsTo l = Link l'}
    (* makes sense only if backward links point to normal nodes, not to backwards links: *)
     then undefined
     else (case ct of
             Link l \<Rightarrow> treeOf' pointsTo (pointsTo l)
            |cNode step cts \<Rightarrow> Node step (fimage (treeOf' pointsTo) cts)
          )
   )"
  apply(relation rel) using rel unfolding rel_def rels_def[abs_def] by auto

(*<*)
end
(*>*)


theory T59
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory PhiSem_Mem_C_Base
  imports PhiSem_Aggregate_Base
begin

section \<open>Semantics\<close>

debt_axiomatization
        MemObj_Size :: \<open>TY \<Rightarrow> nat\<close>
    and idx_step_offset :: \<open>TY \<Rightarrow> nat \<Rightarrow> nat\<close>
  where memobj_size_step : \<open>valid_idx_step T i \<Longrightarrow> MemObj_Size (idx_step_type i T) \<le> MemObj_Size T\<close>
    and idx_step_offset_size:
          \<open>valid_idx_step T i
                \<Longrightarrow> idx_step_offset T i + MemObj_Size (idx_step_type i T) \<le> MemObj_Size T\<close>
    and idx_step_offset_disj:
          \<open>valid_idx_step T i \<Longrightarrow> valid_idx_step T j \<Longrightarrow>
                idx_step_offset T i \<le> idx_step_offset T j \<Longrightarrow>
                idx_step_offset T j < idx_step_offset T i + MemObj_Size (idx_step_type i T) \<Longrightarrow>
                i = j\<close>

primrec index_offset :: \<open>TY \<Rightarrow> nat list \<Rightarrow> nat\<close>
  where \<open>index_offset T [] = 0\<close>
      | \<open>index_offset T (i#idx) = idx_step_offset T i + index_offset (idx_step_type i T) idx\<close>

lemma index_offset_tail[simp]:
  \<open>index_offset T (idx@[i]) = index_offset T idx + idx_step_offset (index_type idx T) i\<close>
  by (induct idx arbitrary: T; simp)

lemma fold_tail:
  \<open>fold f (l @ [x]) = f x o fold f l\<close>
  by (induct l; simp)

lemma index_offset_upper_bound:
  \<open>valid_index T (base@idx) \<Longrightarrow>
   index_offset T (base@idx) + MemObj_Size (index_type (base@idx) T) \<le> index_offset T base + MemObj_Size (index_type base T)\<close>
  apply (induct idx arbitrary: base rule: rev_induct;
         simp del: append_assoc add: append_assoc[symmetric] fold_tail)
  using idx_step_offset_size by fastforce

lemmas index_offset_upper_bound_0 = index_offset_upper_bound[where base = "[]", simplified]

lemma index_offset_bound:
  \<open>valid_index T (base@idx) \<Longrightarrow>
  index_offset T base \<le> index_offset T (base@idx) \<and> index_offset T (base@idx) \<le> index_offset T base + MemObj_Size (index_type base T)\<close>
  apply (induct idx arbitrary: base rule: rev_induct;
         simp del: append_assoc add: append_assoc[symmetric] fold_tail)
  using idx_step_offset_size index_offset_upper_bound by fastforce

lemma index_offset_bound_strict:
  \<open>valid_index T (base@idx) \<Longrightarrow> 0 < MemObj_Size (index_type (base@idx) T) \<Longrightarrow>
  index_offset T base \<le> index_offset T (base@idx) \<and> index_offset T (base@idx) < index_offset T base + MemObj_Size (index_type base T)\<close>
  apply (induct idx arbitrary: base rule: rev_induct;
         simp del: append_assoc add: append_assoc[symmetric] fold_tail)
  using idx_step_offset_size index_offset_upper_bound by fastforce

section \<open>Fiction\<close>

debt_axiomatization Mapof_Val :: \<open>VAL \<Rightarrow> nat list \<rightharpoonup> VAL\<close>
  where Mapof_Val_inj: \<open>Va \<in> Well_Type T \<Longrightarrow> Vb \<in> Well_Type T \<Longrightarrow> Mapof_Val Va = Mapof_Val Vb \<Longrightarrow> Va = Vb\<close>
  and   Mapof_Val_same_dom: \<open>Va \<in> Well_Type T \<Longrightarrow> Vb \<in> Well_Type T \<Longrightarrow> dom (Mapof_Val Va) = dom (Mapof_Val Vb)\<close>
  and   Mapof_not_1[simp]: \<open>Mapof_Val V \<noteq> 1\<close>
  and   Mapof_Val_pull_step: \<open>valid_idx_step T i \<Longrightarrow> V \<in> Well_Type T
                          \<Longrightarrow> pull_map [i] (Mapof_Val V) = Mapof_Val (idx_step_value i V)\<close>
  and   Mapof_Val_mod_step: \<open>valid_idx_step T i \<Longrightarrow> v \<in> Well_Type T
                         \<Longrightarrow> Mapof_Val (idx_step_mod_value i f v) = Mapof_Val v ++ push_map [i] (Mapof_Val (f (idx_step_value i v)))\<close>

lemma Mapof_Val_pull:
  \<open>valid_index T idx \<Longrightarrow> V \<in> Well_Type T \<Longrightarrow> pull_map idx (Mapof_Val V) = Mapof_Val (index_value idx V)\<close>
  apply (induct idx arbitrary: V T; simp)
  using Mapof_Val_pull_step
  by (metis idx_step_value_welltyp pull_map_cons)

lemma total_Mapof_disjoint:
   \<open>g ## (push_map idx (to_share \<circ> h))
\<Longrightarrow> to_share \<circ> f = g * (push_map idx (to_share \<circ> h))
\<Longrightarrow> dom g \<inter> dom (push_map idx (to_share \<circ> h)) = {}\<close>
  using to_share_total_disjoint push_map_to_share by metis

lemma map_add_subsumed_dom:
  \<open>dom f \<subseteq> dom g \<Longrightarrow> f ++ g = g\<close>
  unfolding map_add_def dom_def subset_eq fun_eq_iff apply simp
  by (metis option.case_eq_if option.collapse option.simps(3))

lemma Mapof_Val_mod:
  \<open> valid_index T idx
\<Longrightarrow> v \<in> Well_Type T
\<Longrightarrow> u \<in> Well_Type (index_type idx T)
\<Longrightarrow> Mapof_Val (index_mod_value idx (\<lambda>_. u) v) = Mapof_Val v ++ push_map idx (Mapof_Val u)\<close>
  apply (induct idx arbitrary: u v T; simp)
  using Mapof_Val_same_dom map_add_subsumed_dom apply (metis order_refl)
  by clarify (simp add: idx_step_value_welltyp Mapof_Val_mod_step  push_map_distrib_map_add
                        Mapof_Val_pull_step[symmetric] push_pull_map map_add_subsumed2
                        push_map_push_map)

lemma Mapof_Val_modify_fiction:
   \<open>valid_index T idx
\<Longrightarrow> v \<in> Well_Type T
\<Longrightarrow> u \<in> Well_Type (index_type idx T)
\<Longrightarrow> u'\<in> Well_Type (index_type idx T)
\<Longrightarrow> g ## (push_map idx (to_share \<circ> Mapof_Val u))
\<Longrightarrow> to_share \<circ> (Mapof_Val v) = g * (push_map idx (to_share \<circ> Mapof_Val u))
\<Longrightarrow> to_share \<circ> (Mapof_Val (index_mod_value idx (\<lambda>_. u') v)) = g * (push_map idx (to_share \<circ> Mapof_Val u'))\<close>
  apply (simp add: Mapof_Val_mod to_share_funcomp_map_add push_map_to_share
      times_fun_map_add_right total_Mapof_disjoint[simplified push_map_to_share]
      Mapof_Val_same_dom push_map_dom_eq)
  subgoal premises prems proof -
    have \<open>dom g \<inter> dom (to_share \<circ> push_map idx (Mapof_Val u)) = {}\<close>
      using prems to_share_total_disjoint by blast
    moreover have t1:
      \<open>dom (to_share \<circ> push_map idx (Mapof_Val u)) = dom (to_share \<circ> push_map idx (Mapof_Val u'))\<close>
      using prems by (metis Mapof_Val_same_dom dom_map_option_comp push_map_dom_eq)
    ultimately have \<open>dom g \<inter> dom (to_share \<circ> push_map idx (Mapof_Val u')) = {}\<close> by metis
    note [simp] = times_fun_map_add_right[OF this]
    show ?thesis by simp (metis t1 map_add_subsumed_dom order_eq_refl)
  qed
  done
(* lemma pull_map_share_Mapof_not_eq_1[simp]:
  \<open>valid_index (Typeof v) idx \<Longrightarrow> pull_map idx (share n (to_share \<circ> Mapof_Val v)) = 1 \<longleftrightarrow> n = 0\<close>
  by (cases \<open>n = 0\<close>; simp add: pull_map_share pull_map_to_share Mapof_Val_pull)
*)

lemma map_add_restrict_itself [simp]: \<open>(f ++ g) |` dom g = g\<close>
  unfolding fun_eq_iff restrict_map_def map_add_def
  by (simp add: domIff option.case_eq_if)

lemma Mapof_Val_inj_plus:
  \<open>Va \<in> Well_Type T \<Longrightarrow> Vb \<in> Well_Type T \<Longrightarrow> f ++ Mapof_Val Va = f ++ Mapof_Val Vb \<Longrightarrow> Va = Vb\<close>
proof (rule Mapof_Val_inj, assumption)
  assume tyA: \<open>Va \<in> Well_Type T\<close>
     and tyB: \<open>Vb \<in> Well_Type T\<close>
     and feq: \<open>f ++ Mapof_Val Va = f ++ Mapof_Val Vb\<close>
  then have \<open>(f ++ Mapof_Val Va) |` dom (Mapof_Val Va) = (f ++ Mapof_Val Vb) |` dom (Mapof_Val Vb)\<close>
    using Mapof_Val_same_dom by metis
  note this [simplified]
  then show \<open>Mapof_Val Va = Mapof_Val Vb\<close> .
qed

definition \<open>Valof_Map TY M = (@V. (\<exists>f. f ++ Mapof_Val V = M) \<and> V \<in> Well_Type TY)\<close>

lemma Valof_Map_append[simp]:
  \<open>v \<in> Well_Type T \<Longrightarrow> Valof_Map T (f ++ Mapof_Val v) = v\<close>
  unfolding Valof_Map_def
  using someI[where P=\<open>\<lambda>V. (\<exists>fa. fa ++ Mapof_Val V = f ++ Mapof_Val v) \<and> V \<in> Well_Type T\<close> and x=v, simplified]
        Mapof_Val_inj_plus
  by (metis (no_types, lifting) Mapof_Val_same_dom map_add_restrict_itself)

lemmas Valof_Map[simp] = Valof_Map_append[where f = \<open>Map.empty\<close>, simplified]

lemma
  \<open> perm_ins_homo' f
\<Longrightarrow> perm_ins_homo' (\<lambda>v. f o Mapof_Val v)\<close>

  term \<open>(\<lambda>v. f o Mapof_Val v)\<close>
  term Mapof_Val
  term \<open>((o) to_share) o Mapof_Val\<close>

definition \<open>fic_val_to_share_map TY =
      Interp (\<lambda>m. if m = 1 then {None} else {Some v |v. v \<in> Well_Type TY \<and> to_share o Mapof_Val v = m})\<close>

lemma fic_val_to_share_map[simp]:
  \<open>\<I> (fic_val_to_share_map TY) = (\<lambda>m. if m = 1 then {None} else {Some v |v. v \<in> Well_Type TY \<and> to_share o Mapof_Val v = m})\<close>
  unfolding fic_val_to_share_map_def by (rule Interp_inverse) (simp add: Interpretation_def one_set_def)

paragraph \<open>Basic fictions for resource elements\<close>

definition "share_mem' =
              fiction.pointwise' (\<lambda>seg.  (share_val_fiction (segidx.layout seg)))"

definition "share_mem = fiction_mem (fiction.defined (
              fiction.pointwise' (\<lambda>seg. fiction.fine (share_val_fiction (segidx.layout seg)))))"

lemma share_mem_def':
  \<open>share_mem = fiction_mem (fiction.defined share_mem')\<close>
  unfolding share_mem_def share_mem'_def ..

end


theory T53
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end