subsection \<open>Preconditions and invariants for the atomic step \label{sect:step_invariants}\<close>

theory Step_invariants
  imports Step
begin

text \<open>The dynamic/implementation policies have to be compatible with the static configuration.\<close>

definition "sp_subset s \<equiv>
   (\<forall> p1 p2 . sp_impl_subj_subj s p1 p2 \<longrightarrow> Policy.sp_spec_subj_subj p1 p2)
   \<and> (\<forall> p1 p2 m. sp_impl_subj_obj s p1 p2 m \<longrightarrow> Policy.sp_spec_subj_obj p1 p2 m)"

text \<open>The following predicate expresses the precondition for the atomic step. The precondition depends on the type of the atomic action.\<close>
(*
[SK_IPC dir PREP partner page,SK_IPC dir WAIT partner page,SK_IPC dir (BUF page') partner page]
*)
definition atomic_step_precondition :: "state_t \<Rightarrow> thread_id_t \<Rightarrow> int_point_t \<Rightarrow> bool" where
  "atomic_step_precondition s tid ipt \<equiv>
    case ipt of
       SK_IPC dir WAIT partner page \<Rightarrow>
         \<comment> \<open>the thread managed it past PREP stage\<close>
         ipc_precondition tid dir partner page s
     | SK_IPC dir (BUF page') partner page \<Rightarrow>
         \<comment> \<open>both the calling thread and its communication partner managed it past PREP and WAIT stages\<close>
         ipc_precondition tid dir partner page s
         \<and> ipc_precondition partner (opposite_ipc_direction dir) tid page' s
     | SK_EV_SIGNAL EV_SIGNAL_FINISH partner \<Rightarrow>
        ev_signal_precondition tid partner s
     | _ \<Rightarrow>
         \<comment> \<open>No precondition for other interrupt points.\<close>
         True"

text \<open>The invariant to be preserved by the atomic step function. The invariant is independent from the type of the atomic action.\<close>

definition atomic_step_invariant :: "state_t \<Rightarrow> bool" where
  "atomic_step_invariant s \<equiv>
     sp_subset s"

subsubsection \<open>Atomic steps of SK\_IPC preserve invariants\<close>

lemma set_object_value_invariant:
  shows "atomic_step_invariant s = atomic_step_invariant (set_object_value ob va s)"
proof -
  show ?thesis
    unfolding atomic_step_invariant_def atomic_step_precondition_def ipc_precondition_def
      sp_subset_def set_object_value_def Let_def
    by (simp split: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits)
qed

lemma atomic_ipc_preserves_invariants:
  fixes s :: state_t
    and tid :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (atomic_step_ipc tid dir stage partner page s)"
proof -
  show ?thesis
    proof (cases stage)
    case PREP
      from this assms show ?thesis
        unfolding atomic_step_ipc_def atomic_step_invariant_def by auto
    next
    case WAIT
      from this assms show ?thesis
        unfolding atomic_step_ipc_def atomic_step_invariant_def by auto
    next
    case BUF
      show ?thesis
        using assms BUF set_object_value_invariant
        unfolding atomic_step_ipc_def
        by (simp split: ipc_direction_t.splits)
    qed
qed

lemma atomic_ev_wait_one_preserves_invariants:
  fixes s :: state_t
    and tid :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (atomic_step_ev_wait_one tid s)"
  proof -
   from assms show ?thesis
   unfolding atomic_step_ev_wait_one_def atomic_step_invariant_def sp_subset_def
   by auto
 qed

lemma atomic_ev_wait_all_preserves_invariants:
  fixes s :: state_t
    and tid :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (atomic_step_ev_wait_all tid s)"
  proof -
   from assms show ?thesis
   unfolding atomic_step_ev_wait_all_def atomic_step_invariant_def sp_subset_def
   by auto
 qed

lemma atomic_ev_signal_preserves_invariants:
  fixes s :: state_t
    and tid :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (atomic_step_ev_signal tid  partner s)"
  proof -
   from assms show ?thesis
   unfolding atomic_step_ev_signal_def atomic_step_invariant_def sp_subset_def
   by auto
 qed

subsubsection \<open>Summary theorems on atomic step invariants\<close>

text \<open>Now we are ready to show that an atomic step from the current interrupt point
        in any thread preserves invariants.\<close>

theorem atomic_step_preserves_invariants:
  fixes s :: state_t
    and tid :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (atomic_step s a)"
proof (cases a)
  case SK_IPC
    then show ?thesis unfolding atomic_step_def
    using assms atomic_ipc_preserves_invariants
    by simp
  next  case (SK_EV_WAIT ev_wait_stage consume)
    then show ?thesis
    proof (cases consume)
     case EV_CONSUME_ALL
      then show ?thesis unfolding atomic_step_def
      using SK_EV_WAIT assms atomic_ev_wait_all_preserves_invariants
      by (simp split: ev_wait_stage_t.splits)
     next case EV_CONSUME_ONE
      then show ?thesis unfolding atomic_step_def
      using SK_EV_WAIT assms atomic_ev_wait_one_preserves_invariants
      by (simp split: ev_wait_stage_t.splits)
    qed
  next case SK_EV_SIGNAL
   then show ?thesis unfolding atomic_step_def
   using assms atomic_ev_signal_preserves_invariants
   by (simp add: ev_signal_stage_t.splits)
  next case NONE
   then show ?thesis unfolding atomic_step_def
   using assms
   by auto
qed

text \<open>Finally, the invariants do not depend on the current thread. That is,
the context switch preserves the invariants, and an atomic step that is
not a context switch does not change the current thread.\<close>

theorem cswitch_preserves_invariants:
  fixes s :: state_t
    and new_current :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "atomic_step_invariant (s \<lparr> current := new_current \<rparr>)"
proof -
  let ?s1 = "s \<lparr> current := new_current \<rparr>"
  have "sp_subset s = sp_subset ?s1"
    unfolding sp_subset_def by auto
  from assms this show ?thesis
    unfolding atomic_step_invariant_def by metis
qed

theorem atomic_step_does_not_change_current_thread:
  shows "current (atomic_step s ipt) = current s"
proof -
  show ?thesis
    unfolding atomic_step_def
          and atomic_step_ipc_def
          and set_object_value_def Let_def
          and atomic_step_ev_wait_one_def atomic_step_ev_wait_all_def
          and atomic_step_ev_signal_def
    by (simp split: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                        ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)
qed

end


theory Abstract_Reachability_Analysis
  imports
  Abstract_Rigorous_Numerics
  Affine_Arithmetic.Affine_Arithmetic
  "../Refinement/Refine_String"
  "../Refinement/Refine_Folds"
  Ordinary_Differential_Equations.Flow
  Runge_Kutta
begin

subsection \<open>Misc\<close>

lemma nth_concat_exists:
  "\<exists>k j. concat xs ! i = xs ! k ! j \<and> k < length xs \<and> j < length (xs ! k)"
  if "i < length (concat xs)"
  using that
proof (induction xs arbitrary: i)
  case Nil
  then show ?case by auto
next
  case (Cons xs xss)
  from Cons.prems consider "i < length xs"
    | "i \<ge> length xs" "i < length xs + length (concat xss)"
    by (cases "i < length xs") auto
  then show ?case
  proof cases
    case 1
    then show ?thesis
      by (force simp: nth_append intro: exI[where x=i] exI[where x=0])
  next
    case 2
    then have "i - length xs < length (concat xss)" by arith
    with Cons.IH[of "i - length xs"]
    obtain k j where
      "concat xss ! (i - length xs) = xss ! k ! j" "k < length xss" "j < length (xss ! k)"
      by auto
    then show ?thesis
      using 2
      by (fastforce simp: nth_append nth_Cons split: nat.splits
          intro: exI[where x=j] exI[where x="k + 1"])
  qed
qed

lemma nth_concatE:
  assumes "i < length (concat xs)"
  obtains k j where "concat xs ! i = xs ! k ! j" "k < length xs" "j < length (xs ! k)"
  apply atomize_elim
  using assms nth_concat_exists by blast

lemma max_Var_floatariths_concat:
  "max_Var_floatariths (concat xs) \<le> k"
  if "\<And>x. x \<in> set xs \<Longrightarrow> max_Var_floatariths x \<le> k"
  using that max_Var_floatarith_le_max_Var_floatariths_nthI
  by (fastforce simp: in_set_conv_nth intro!: max_Var_floatariths_leI
      elim!: nth_concatE)

lemma max_Var_floatariths_list_update:
  "max_Var_floatariths (xs[xa := y]) \<le> k"
  if "max_Var_floatariths (xs) \<le> k"
  and "max_Var_floatarith y \<le> k"
  by (metis neq_le_trans linorder_le_cases list_update_beyond
      max_Var_floatariths_list_updateI that)

lemma max_Var_floatarith_0[simp]: "max_Var_floatarith 0 = 0"
  and max_Var_floatarith_1[simp]: "max_Var_floatarith 1 = 0"
  by (auto simp: zero_floatarith_def one_floatarith_def)

lemma list_set_rel_br: "\<langle>Id\<rangle>list_set_rel = br set distinct"
  by (auto simp: list_set_rel_def)

lemma
  br_list_relD:
  shows "(x, y) \<in> \<langle>br a i\<rangle>list_set_rel \<Longrightarrow> y = a ` set x \<and> list_all i x"
  apply (auto simp: list_set_rel_def br_def list_rel_def)
  subgoal premises prems for s t
    using prems
    by (induction arbitrary: y rule: list.rel_induct) auto
  subgoal premises prems for s t
    using prems
    by (induction arbitrary: y rule: list.rel_induct) auto
  subgoal premises prems for s
    using prems
    by (induction arbitrary: y rule: list.rel_induct) auto
  done

lemma sctn_rel_br: "\<langle>br a I\<rangle>sctn_rel = br (\<lambda>x. case x of Sctn n p \<Rightarrow> Sctn (a n) p) (\<lambda>x. I (normal x))"
  apply (auto simp: sctn_rel_def br_def in_rel_def[abs_def] split: sctn.splits)
  subgoal for b x1 x2 by (cases b) auto
  subgoal for a b by (cases a; cases b) auto
  done

lemma br_list_rel: "\<langle>br a I\<rangle>list_rel = br (map a) (list_all I)"
  by (fastforce simp: list_rel_def br_def list_all2_iff Ball_def in_set_zip list_all_length
      intro!: nth_equalityI)

lemma list_set_rel_brp: "\<langle>br a I\<rangle>list_set_rel = br (\<lambda>xs. a ` set xs) (\<lambda>xs. list_all I xs \<and> distinct (map a xs))"
  unfolding list_set_rel_def br_list_rel br_chain o_def o_def
  by (auto)

declare INF_cong_simp [cong] SUP_cong_simp [cong] image_cong_simp [cong del]

context auto_ll_on_open begin

definition "stable_on CX trap \<longleftrightarrow>
  (\<forall>t x0. flow0 x0 t \<in> trap \<longrightarrow> t \<in> existence_ivl0 x0 \<longrightarrow> t > 0 \<longrightarrow>
    (\<forall>s\<in>{0<..t}. flow0 x0 s \<in> CX) \<longrightarrow> x0 \<in> trap)"

lemma stable_onD:
  "\<And>t x0. flow0 x0 t \<in> trap \<Longrightarrow> t \<in> existence_ivl0 x0 \<Longrightarrow> t > 0 \<Longrightarrow>
      (\<And>s. 0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> flow0 x0 s \<in> CX) \<Longrightarrow>
      x0 \<in> trap"
  if "stable_on CX trap"
  using that by (auto simp: stable_on_def)

lemma nonneg_interval_mem_existence_ivlI[intro]:\<comment> \<open>TODO: move!\<close>
  "0 \<le> t1 \<Longrightarrow> t1 \<le> t2 \<Longrightarrow> t2 \<in> existence_ivl0 x0 \<Longrightarrow> {t1..t2} \<subseteq> existence_ivl0 x0"
  "t1 \<le> t2 \<Longrightarrow> t2 \<le> 0 \<Longrightarrow> t1 \<in> existence_ivl0 x0 \<Longrightarrow> {t1..t2} \<subseteq> existence_ivl0 x0"
  "t1 \<le> 0 \<Longrightarrow> 0 \<le> t2 \<Longrightarrow> t1 \<in> existence_ivl0 x0 \<Longrightarrow> t2 \<in> existence_ivl0 x0 \<Longrightarrow> {t1..t2} \<subseteq> existence_ivl0 x0"
    apply auto
  apply (drule ivl_subset_existence_ivl) apply auto
  apply (drule ivl_subset_existence_ivl') apply auto
  apply (drule segment_subset_existence_ivl, assumption)
  apply (auto simp: closed_segment_eq_real_ivl)
  done

lemma interval_subset_existence_ivl:
  "t \<in> existence_ivl0 x0 \<Longrightarrow> s \<in> existence_ivl0 x0 \<Longrightarrow> t \<le> s \<Longrightarrow> {t .. s} \<subseteq> existence_ivl0 x0"
  using segment_subset_existence_ivl[of s x0 t]
  by (auto simp: closed_segment_eq_real_ivl)

end

lemma(in c1_on_open_euclidean) diff_existence_ivl_iff[simp]:\<comment> \<open>TODO: move!, also to @{term auto_ll_on_open}\<close>
  "t2 - t1 \<in> existence_ivl0 (flow0 x0 t1) \<longleftrightarrow> t2 \<in> existence_ivl0 x0"
  if "t1 \<le> t2" "t1 \<in> existence_ivl0 x0"
  apply auto
   apply (drule existence_ivl_trans[OF that(2)])
   apply (auto intro!: diff_existence_ivl_trans that)
  done

lemma (in auto_ll_on_open) flow_trans':
  "flow0 (flow0 x0 t1) t2 = flow0 x0 (t1 + t2)"
  if "t1 \<in> existence_ivl0 x0" "t1 + t2 \<in> existence_ivl0 x0"
  apply (subst flow_trans)
  using that
  by (auto intro!: existence_ivl_trans')

context auto_ll_on_open begin

definition "flowpipe0 X0 hl hu CX X1 \<longleftrightarrow> 0 \<le> hl \<and> hl \<le> hu \<and> X0 \<subseteq> X \<and> CX \<subseteq> X \<and> X1 \<subseteq> X \<and>
  (\<forall>(x0) \<in> X0. \<forall>h \<in> {hl .. hu}. h \<in> existence_ivl0 x0 \<and> (flow0 x0 h) \<in> X1 \<and> (\<forall>h' \<in> {0 .. h}. (flow0 x0 h') \<in> CX))"

lemma flowpipe0D:
  assumes "flowpipe0 X0 hl hu CX X1"
  shows flowpipe0_safeD: "X0 \<union> CX \<union> X1 \<subseteq> X"
    and flowpipe0_nonneg: "0 \<le> hl" "hl \<le> hu"
    and flowpipe0_exivl: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0) \<in> X0 \<Longrightarrow> h \<in> existence_ivl0 x0"
    and flowpipe0_discrete: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0) \<in> X0 \<Longrightarrow> (flow0 x0 h) \<in> X1"
    and flowpipe0_cont: "hl \<le> h \<Longrightarrow> h \<le> hu \<Longrightarrow> (x0) \<in> X0 \<Longrightarrow> 0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> (flow0 x0 h') \<in> CX"
  using assms
  by (auto simp: flowpipe0_def)

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

end

subsection \<open>Options\<close>

definition [refine_vcg_def]: "precision_spec = SPEC (\<lambda>prec::nat. True)"
definition [refine_vcg_def]: "adaptive_atol_spec = SPEC (\<lambda>x::real. True)"
definition [refine_vcg_def]: "adaptive_rtol_spec = SPEC (\<lambda>x::real. True)"
definition [refine_vcg_def]: "method_spec = SPEC (\<lambda>m::nat. True)"
definition [refine_vcg_def]: "start_stepsize_spec = SPEC (\<lambda>x::real. x > 0)"
definition [refine_vcg_def]: "iterations_spec = SPEC (\<lambda>n::nat. True)"
definition [refine_vcg_def]: "halve_stepsizes_spec = SPEC (\<lambda>n::nat. True)"
definition [refine_vcg_def]: "widening_mod_spec = SPEC (\<lambda>n::nat. True)"
definition [refine_vcg_def]: "rk2_param_spec = SPEC (\<lambda>r::real. 0 < r \<and> r \<le> 1)"

typedef ode_ops = "{(ode_e::floatarith list, safe_form::form).
  open_form safe_form \<and>
  max_Var_floatariths ode_e \<le> length ode_e \<and>
  max_Var_form safe_form \<le> length ode_e}" \<comment> \<open>ode on open domain, welldefined\<close>
  by (auto intro!: exI[where x="[floatarith.Num 0]"]
      exI[where x="Less (floatarith.Num 0) (floatarith.Num 1)"])
setup_lifting type_definition_ode_ops

lift_definition ode_expression::"ode_ops \<Rightarrow> floatarith list" is fst .
lift_definition safe_form_expr::"ode_ops \<Rightarrow> form" is snd .
    \<comment> \<open>TODO: should better called it domain of definition of ODE,
                its main use is to exclude e.g. division by zero on the rhs.\<close>

lemma open_form_ode_op[intro, simp]: "open_form (safe_form_expr odo)"
  and max_Var_ode_expression: "max_Var_floatariths (ode_expression odo) \<le> length (ode_expression odo)"
  and max_Var_form_safe_form_expr: "max_Var_form (safe_form_expr odo) \<le> length (ode_expression odo)"
  by (transfer, auto)+

lift_definition (code_dt) mk_ode_ops::"floatarith list \<Rightarrow> form \<Rightarrow> ode_ops option" is
  "\<lambda>ode_e safe_form.
    if (open_form safe_form \<and> max_Var_floatariths ode_e \<le> length ode_e \<and> max_Var_form safe_form \<le> length ode_e)
    then Some (ode_e, safe_form) else None"
  by (auto simp:)

lemma
  assumes "mk_ode_ops e s = Some odo"
  shows ode_expression_mk_ode_ops: "ode_expression odo = e"
    and safe_form_expr_mk_ode_ops: "safe_form_expr odo = s"
  using assms
  by (transfer, simp split: if_splits prod.splits)+

locale ode_operations = fixes ode_ops::ode_ops begin

definition "ode_e = ode_expression ode_ops"
definition "safe_form = safe_form_expr ode_ops"

definition ode::"'a \<Rightarrow> 'a::executable_euclidean_space"
  where "ode x = eucl_of_list (interpret_floatariths ode_e (list_of_eucl x))"

definition "ode_d_expr_nth N n i =
    FDERIV_floatarith
     (FDERIV_n_floatarith (ode_e  ! i) [0..<N] (map floatarith.Var [N..<2 * N]) n) [0..<N]
         (map floatarith.Var [2 * N..<3 * N])"

definition "ode_d_expr N n =
    (FDERIV_floatariths
      (FDERIV_n_floatariths ode_e [0..<N] (map floatarith.Var [N..<2 * N]) n)
      [0..<N]
      (map floatarith.Var [2 * N..< 3 * N]))"

definition ode_d_raw::"nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a::executable_euclidean_space"
  where "ode_d_raw n x dn d =
    eucl_of_list (interpret_floatariths (ode_d_expr DIM('a) n) (list_of_eucl x @ list_of_eucl dn @ list_of_eucl d))"

definition "ode_fa_nth xs i = subst_floatarith (\<lambda>i. xs ! i) (ode_e ! i)"

definition "ode_fa xs = map (subst_floatarith (\<lambda>i. xs ! i)) ode_e"

definition "ode_d_fa_nth n xs ds i = subst_floatarith (\<lambda>i. (xs@ds@ds) ! i) (ode_d_expr_nth (length xs) n i)"

definition "ode_d_fa n xs ds = map (subst_floatarith (\<lambda>i. (xs@ds@ds) ! i)) (ode_d_expr (length xs) n)"

definition safe::"'a::executable_euclidean_space \<Rightarrow> bool"
  where "safe x \<longleftrightarrow>
    length ode_e = DIM('a) \<and>
    max_Var_floatariths ode_e \<le> DIM('a) \<and>
    open_form safe_form \<and>
    max_Var_form safe_form \<le> DIM('a) \<and>
    interpret_form safe_form (list_of_eucl x) \<and>
    isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x)"

definition "Csafe = Collect safe"

definition "euler_incr_fas_nth X0 h CX i = X0 ! i + h * (ode_fa_nth CX i)"

definition "euler_incr_fas X0 h CX = map (euler_incr_fas_nth X0 h CX) [0..<length X0]"

definition "euler_err_fas_nth X0 h CX i = ((h ^\<^sub>e 2) / floatarith.Num 2) * ode_d_fa_nth 0 CX (ode_fa CX) i"

definition "euler_err_fas X0 h CX = map (euler_err_fas_nth X0 h CX) [0..<length X0]"

definition "euler_fas X0 h CX =
  map (\<lambda>i. (euler_incr_fas_nth X0 h X0 i + euler_err_fas_nth X0 h CX i)) [0..<length X0] @
  euler_err_fas X0 h CX"

definition "rk2_fas_err_nth rkp x0 h cx s2 i =
  ((((h ^\<^sub>e 3 / 6) *
        (ode_d_fa_nth 1 cx (ode_fa cx) i +
         ode_d_fa_nth 0 cx (ode_d_fa 0 cx (ode_fa cx)) i)))
      - ((h ^\<^sub>e 3 * rkp / 4) *
          ode_d_fa_nth 1 (euler_incr_fas x0 (s2 * h * rkp) x0) (ode_fa x0) i))"

definition "rk2_fas_err rkp x0 h cx s2 = map (rk2_fas_err_nth rkp x0 h cx s2) [0..<length x0]"

definition "rk2_fas rkp x0 h cx s2 =
  (map (\<lambda>i.
      ((x0 ! i +
        h * ((1 - (1 / (rkp * 2))) * ode_fa_nth x0 i +
          (1 / (rkp * 2)) * ode_fa_nth (euler_incr_fas x0 (h * rkp) x0) i))
      + rk2_fas_err_nth rkp x0 h cx s2 i)) [0..<length x0]) @ rk2_fas_err rkp x0 h cx s2"

lemma ode_d_expr_nth: "i < length ode_e \<Longrightarrow> ode_d_expr_nth N n i = ode_d_expr N n ! i "
  by (auto simp: ode_d_expr_nth_def ode_d_expr_def
      FDERIV_n_floatariths_nth)

lemma length_ode_d_expr[simp]: "length (ode_d_expr f n) = length ode_e"
  by (induction n) (auto simp: ode_d_expr_def FDERIV_n_floatariths_def)

lemma ode_fa_nth: "i < length ode_e \<Longrightarrow> ode_fa xs ! i = ode_fa_nth xs i"
  by (auto simp: ode_fa_nth_def ode_fa_def)

lemma ode_d_fa_nth: "i < length ode_e \<Longrightarrow> ode_d_fa_nth n xs ds i = ode_d_fa n xs ds ! i"
  by (auto simp: ode_d_fa_def ode_d_fa_nth_def ode_d_expr_nth)

lemma length_ode_d_fa[simp]: "length (ode_d_fa n xs ds) = length ode_e"
  by (auto simp: ode_d_fa_def FDERIV_n_floatariths_def)

lemma length_rk2_fas_err[simp]: "length (rk2_fas_err rkp x0 h cx s2) = length x0"
  by (simp add: rk2_fas_err_def)

lemma length_euler_incr_fas[simp]: "length (euler_incr_fas X0 h CX) = length X0"
  by (auto simp: euler_incr_fas_def)

lemma length_euler_err_fas[simp]: "length (euler_err_fas X0 h CX) = length X0"
  by (auto simp: euler_err_fas_def)

lemma length_euler_floatarith[simp]: "length (euler_fas X0 h CX) = 2 * length X0"
  by (auto simp: euler_fas_def)

lemma length_rk2_fas[simp]: "length (rk2_fas rkp x0 h cx s2) = 2 * length x0"
  by (simp add: rk2_fas_def)

lemma open_safe: "open Csafe"
proof -
  have leq: "list_updates [0..<DIM('a)] (list_of_eucl x) (replicate DIM('a) 0) = list_of_eucl x" for x::'a
    by (auto intro!: nth_equalityI simp: list_updates_nth)
  have "(Csafe::'a set) =
    (if length ode_e = DIM('a) \<and> max_Var_floatariths ode_e \<le> DIM('a) \<and> max_Var_form safe_form \<le> DIM('a) \<and> open_form safe_form then
      {x. interpret_form safe_form (list_of_eucl x)} \<inter>
      {x. isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x)}
    else {})"
    by (auto simp: Csafe_def safe_def)
  also have "open \<dots>"
    apply (auto intro!: open_Int)
    subgoal premises prems using open_form[OF prems(4), where 'a='a, of "[0..<DIM('a)]" "replicate (DIM('a)) 0"]
      by (auto simp: leq)
    subgoal
      apply (rule isFDERIV_open)
      apply (rule order_trans)
      apply assumption
      apply arith
      done
    done
  finally show ?thesis .
qed

lemma safeD:
  fixes x::"'a::executable_euclidean_space"
  assumes "x \<in> Csafe"
  shows "interpret_form safe_form (list_of_eucl x)"
    and safe_isFDERIV: "isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x)"
  using assms
  by (auto simp: Csafe_def safe_def)

lemma
  fixes x::"'a::executable_euclidean_space"
  shows safe_max_Var: "x \<in> Csafe \<Longrightarrow> max_Var_floatariths ode_e \<le> DIM('a)"
    and safe_length: "x \<in> Csafe \<Longrightarrow> length ode_e = DIM('a)"
    and safe_max_Var_form: "x \<in> Csafe \<Longrightarrow> max_Var_form safe_form \<le> DIM('a)"
  by (auto simp: safe_def Csafe_def)

lemma safe_isFDERIV_append:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<in> Csafe \<Longrightarrow> isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x @ xs)"
  apply (rule isFDERIV_max_Var_congI)
   apply (rule safe_isFDERIV)
   apply assumption
  using safe_max_Var[of x]
  by (auto simp: nth_append)

lemma ode_d_raw_0:
  assumes "x \<in> Csafe"
  shows "(ode has_derivative ode_d_raw 0 x d) (at x)"
  using assms safe_max_Var[OF assms] safe_length[OF assms]
  unfolding ode_def ode_d_raw_def ode_d_expr_def
  apply (intro interpret_floatarith_FDERIV_floatariths[THEN has_derivative_eq_rhs])
     apply (auto simp: isFDERIV_def FDERIV_n_floatariths_def safe_max_Var nth_append
      max_Var_floatariths_Max Csafe_def safe_def
      intro!: arg_cong[where f=eucl_of_list] ext interpret_floatariths_FDERIV_floatariths_cong
        freshs_floatariths_max_Var_floatarithsI
        max_Var_floatarith_le_max_Var_floatariths[le])
  apply (rule interpret_floatariths_max_Var_cong)
  apply (auto simp: max_Var_floatariths_Max Max_gr_iff nth_append
      dest!: less_le_trans[OF _ max_Var_floatarith_DERIV_floatarith])
   apply (drule max_Var_floatariths_lessI) apply simp
  apply (auto dest!: less_le_trans[OF _ safe_max_Var[OF assms]])
   apply (drule max_Var_floatariths_lessI) apply simp
  apply (auto dest!: less_le_trans[OF _ safe_max_Var[OF assms]])
  done

lemma not_fresh_odeD: "x \<in> Csafe \<Longrightarrow> \<not>fresh_floatariths ode_e i \<Longrightarrow> i < DIM('a)" for x::"'a::executable_euclidean_space"
  using fresh_floatariths_max_Var[of ode_e i] safe_max_Var[of x] by arith

lemma safe_isnFDERIV:
  fixes x::"'a::executable_euclidean_space"
  assumes "x \<in> Csafe"
  shows "isnFDERIV DIM('a) ode_e [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl x @ ys) n"
  apply (rule isFDERIV_imp_isnFDERIV)
     apply (rule isFDERIV_max_Var_congI)
      apply (rule safe_isFDERIV[OF assms])
  using safe_max_Var[OF assms] safe_length[OF assms]
  by (auto simp: nth_append)

lemma safe_isnFDERIVI:
  assumes "(eucl_of_list xs::'a::executable_euclidean_space) \<in> Csafe"
  assumes [simp]: "length xs = DIM('a)" "length ds = DIM('a)"
  shows "isnFDERIV DIM('a) ode_e [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (xs@ds) n"
proof -
  have "isnFDERIV DIM('a) ode_e [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl (eucl_of_list xs::'a)@ds) n"
    by (rule safe_isnFDERIV; fact)
  also
  have "list_of_eucl (eucl_of_list xs::'a) = xs"
    by (auto intro!: nth_equalityI)
  finally show ?thesis .
qed

lemma dest_Num_eq_Some_iff[simp]: "dest_Num_fa fa = (Some x) \<longleftrightarrow> fa = floatarith.Num x"
  by (cases fa) auto

lemma ode_d_raw_Suc:
  includes floatarith_notation
  assumes "x \<in> Csafe"
  shows "((\<lambda>x. ode_d_raw n x d d) has_derivative ode_d_raw (Suc n) x d) (at x)"
proof -
  let ?shift = "\<lambda>x. floatarith.Var (if 2 * DIM('a) \<le> x \<and> x < 3 * DIM('a) then x - DIM('a) else x)"
  have subst_ode_e[simp]: "map (subst_floatarith ?shift) ode_e = ode_e"
    apply (auto intro!: nth_equalityI)
    apply (rule subst_floatarith_Var_max_Var_floatarith)
    by (auto dest!: max_Var_floatariths_lessI
        less_le_trans[OF _ safe_max_Var[OF assms]])
  have map_shift[simp]:
    "(map ?shift [DIM('a)..<2 * DIM('a)]) = (map floatarith.Var [DIM('a)..<2 * DIM('a)])"
    "(map ?shift [2 * DIM('a)..<3 * DIM('a)]) =
        (map floatarith.Var [DIM('a)..<2 * DIM('a)])"
    by (auto intro!: nth_equalityI)

  show ?thesis
    unfolding ode_def ode_d_raw_def ode_d_expr_def
    apply (rule interpret_floatarith_FDERIV_floatariths_append[THEN has_derivative_eq_rhs])
    subgoal
    proof -
      let ?shift = "\<lambda>x. if 2 * DIM('a) \<le> x \<and> x < 3 * DIM('a) then x - DIM('a) else x"
      have mv: "max_Var_floatariths
          (FDERIV_floatariths (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n)
          [0..<DIM('a)] (map floatarith.Var [2 * DIM('a)..<3 * DIM('a)])) \<le> 3 * DIM('a)"
        and mv2: "max_Var_floatariths
              (FDERIV_floatariths (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n)
                [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)])) \<le> 2 * DIM('a)"
        by (auto intro!:
            max_Var_floatarith_FDERIV_floatariths[le]
            max_Var_floatarith_FDERIV_n_floatariths[le]
            safe_max_Var[OF assms, le])
      have eq: "(map (subst_floatarith (\<lambda>i. floatarith.Var (if 2 * DIM('a) \<le> i \<and> i < 3 * DIM('a) then i - DIM('a) else i)))
       ((FDERIV_floatariths (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n)
         [0..<DIM('a)] (map floatarith.Var [2 * DIM('a)..<3 * DIM('a)])))) =
      (FDERIV_floatariths (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n)
          [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]))"
        apply (rule nth_equalityI)
         apply auto defer
        apply (subst subst_floatarith_Var_FDERIV_floatarith[where 'a='a], force, force, force)
        apply (subst subst_floatarith_Var_FDERIV_n_nth[where 'a='a], force, force, force, force)
        by (simp add: o_def)
      show ?thesis
        apply (subst isFDERIV_subst_Var_floatarith[symmetric, where s="?shift"])
        subgoal by (auto intro!: mv[le] max_Var_floatariths_fold_const_fa[le])
        subgoal by (auto simp: nth_append)
        subgoal by (auto intro!: mv[le])
        subgoal
        proof -
          have "isnFDERIV DIM('a) ode_e [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl d) (Suc (Suc n))"
            apply (rule safe_isnFDERIVI)
            using assms
            by auto
          from this[simplified, THEN conjunct1]
          show ?thesis
            unfolding eq isnFDERIV.simps
            apply (rule isFDERIV_max_Var_congI)
            apply (frule less_le_trans[OF _ mv2])
            apply (auto simp: nth_append)
            done
        qed
        done
    qed
    subgoal
      by (auto intro!: safe_max_Var[OF assms, le]
          max_Var_floatarith_FDERIV_floatariths[le]
          max_Var_floatarith_FDERIV_n_floatariths[le])
    subgoal using safe_length assms by simp
    subgoal
      apply (auto simp add: nth_append
          intro!: ext arg_cong[where f=eucl_of_list] interpret_floatariths_FDERIV_floatariths_cong
          freshs_floatariths_max_Var_floatarithsI
          safe_max_Var[OF assms, le]
          max_Var_floatarith_FDERIV_floatariths[le]
          max_Var_floatarith_FDERIV_n_floatariths[le])
      apply (rule nth_equalityI)
       apply auto
      subgoal premises prems for h i j
      proof -
        have *: "(list_of_eucl x @ list_of_eucl d @ list_of_eucl d @ list_of_eucl h) =
        (map (\<lambda>i. interpret_floatarith (?shift i)
             (list_of_eucl x @ list_of_eucl d @ list_of_eucl d @ list_of_eucl h)) [0..<4 * DIM('a)])"
          by (auto intro!: nth_equalityI simp: nth_append)
        have mv_le: "max_Var_floatarith
                (DERIV_floatarith j
                  (FDERIV_floatarith
                    (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n ! i)
                    [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]))) \<le>
                2 * DIM('a)"
          "max_Var_floatarith
     (DERIV_floatarith j
       (FDERIV_floatarith (FDERIV_n_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]) n ! i)
         [0..<DIM('a)] (map floatarith.Var [2 * DIM('a)..<3 * DIM('a)])))
      \<le> 3 * DIM('a)"
          by (auto intro!: prems
              safe_max_Var[OF assms, le]
              max_Var_floatarith_le_max_Var_floatariths_nth[le]
              max_Var_floatarith_DERIV_floatarith[le]
              max_Var_floatarith_FDERIV_floatarith[le]
              max_Var_floatarith_FDERIV_n_floatariths[le])
        show ?thesis
          apply (subst *)
          apply (subst interpret_floatarith_subst_floatarith[symmetric])
           apply (auto intro!: prems mv_le[le])
          apply (subst subst_floatarith_Var_DERIV_floatarith, use prems in force)
          apply (subst subst_floatarith_Var_FDERIV_floatarith[where 'a='a], force, force, force)
          apply (subst subst_floatarith_Var_FDERIV_n_nth[where 'a='a], force, force, force, use prems in force)
          apply (auto simp: o_def prems nth_append intro!: interpret_floatarith_max_Var_cong
              dest!: less_le_trans[OF _ mv_le(1)])
          done
      qed
      done
    done
qed

lift_definition ode_d::"nat \<Rightarrow> 'a::executable_euclidean_space \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a" is
  "\<lambda>n x dn d. if x \<in> Csafe
    then ode_d_raw n x dn d
    else 0"
  subgoal for n x dn
    apply (cases n)
    subgoal
      by (cases "x \<in> Csafe")
       (auto intro: has_derivative_bounded_linear[OF ode_d_raw_0])
    subgoal for n'
      apply (cases "x \<in> Csafe")
      subgoal
        apply (simp del: isnFDERIV.simps)
        apply (rule has_derivative_bounded_linear)
        apply (rule ode_d_raw_Suc)
        apply assumption
        done
      subgoal by (simp del: isnFDERIV.simps)
      done
    done
  done

definition "ode_d1 x = ode_d 0 x 0"

lemma ode_has_derivative:
  assumes "isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x)"
  assumes "(x::'a::executable_euclidean_space) \<in> Csafe"
  shows "(ode has_derivative ode_d1 x) (at x)"
proof -
  from assms(1) have *: "x \<in> Csafe \<Longrightarrow> isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x @ list_of_eucl (0::'a))"
    apply (rule isFDERIV_max_Var_congI)
    using safe_max_Var[of x]
    by (auto simp: nth_append)
  show ?thesis
    unfolding ode_d1_def
    apply (transfer fixing: x)
    apply (rule ode_d_raw_0[THEN has_derivative_eq_rhs])
    by (auto intro!: * assms)
qed

lemma ode_has_derivative_safeI:
  assumes "x \<in> Csafe"
  shows "(ode has_derivative ode_d1 x) (at x)"
  using assms
  by (auto simp: safe_def Csafe_def intro!: ode_has_derivative)

lemma ode_d1_eq: "ode_d1 x = ode_d 0 x j"
  unfolding ode_d1_def
proof (transfer fixing: x j, rule ext, cases "x \<in> Csafe", clarsimp_all, goal_cases)
  case (1 d)
  have "isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x @ list_of_eucl (0::'a)) =
    isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x @ list_of_eucl j)"
    by (rule isFDERIV_max_Var_cong)
       (auto dest!: less_le_trans[OF _ safe_max_Var[OF 1]] simp: nth_append)
  moreover
  have "interpret_floatariths (FDERIV_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [2 * DIM('a)..<3 * DIM('a)]))
     (list_of_eucl x @ list_of_eucl (0::'a) @ list_of_eucl d) =
    interpret_floatariths (FDERIV_floatariths ode_e [0..<DIM('a)] (map floatarith.Var [2 * DIM('a)..<3 * DIM('a)]))
     (list_of_eucl x @ list_of_eucl j @ list_of_eucl d)"
    using 1
    by (intro interpret_floatariths_fresh_cong)
      (auto dest!: not_fresh_FDERIV_floatariths not_fresh_odeD
        simp: nth_append)
  ultimately show ?case
    by (auto simp: ode_d_raw_def ode_d_expr_def)
qed

lemma eventually_Collect_open:
  assumes "P x" "open (Collect P)"
  shows "eventually P (at x)"
  using assms(1) assms(2) eventually_at_topological by blast

lemma ode_d_has_derivative:
  assumes "x \<in> Csafe"
  shows "((\<lambda>x. ode_d n x d d) has_derivative ode_d (Suc n) x d) (at x)"
  apply (transfer fixing: n d x)
  using assms
  apply (simp del: isnFDERIV.simps)
  apply (rule if_eventually_has_derivative)
  subgoal by (rule ode_d_raw_Suc)
  subgoal
    by (rule eventually_Collect_open)
      (auto simp: safe_max_Var[OF assms] open_safe intro!: safe_max_Var[OF assms, le])
  subgoal by (simp add: isnFDERIV.simps)
  subgoal by simp
  done

lemma ode_d1_has_derivative:
  assumes "x \<in> Csafe"
  shows "(ode_d1 has_derivative ode_d (Suc 0) x) (at x)"
proof (rule blinfun_has_derivative_componentwiseI[THEN has_derivative_eq_rhs])
  fix i::'a assume "i \<in> Basis"
  show "((\<lambda>x. blinfun_apply (ode_d1 x) i) has_derivative ode_d (Suc 0) x i) (at x)"
    unfolding ode_d1_eq[of _ i]
    apply (rule ode_d_has_derivative)
    apply fact
    done
next
  show "(\<lambda>xa. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply (ode_d (Suc 0) x i) xa)) = ode_d (Suc 0) x"
    apply (rule ext)
    apply (auto intro!: ext euclidean_eqI[where 'a='a] blinfun_euclidean_eqI
        simp: blinfun.bilinear_simps inner_sum_left inner_Basis if_distrib if_distribR
        sum.delta' cong: if_cong)
    apply (rule arg_cong[where f="\<lambda>x. x \<bullet> b" for b])
  proof goal_cases
    case (1 j i b)
    from eventually_isFDERIV[where params=Nil, simplified, OF safe_isFDERIV[OF assms] order_trans[OF safe_max_Var[of x]]]
    have "\<forall>\<^sub>F x in at x. isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl x)"
      by (auto simp: assms)
    then obtain S where S: "x \<in> S" "open S" "S \<subseteq> Csafe"
      and "\<And>xa. xa \<in> S \<Longrightarrow> xa \<noteq> x \<Longrightarrow> isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl xa)"
      using assms open_safe safe_isFDERIV by auto
    then have S_FDERIV: "\<And>s. s \<in> S \<Longrightarrow>
      isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl s)"
      using safe_isFDERIV[OF assms]
      by auto
    interpret second_derivative_on_open "ode" ode_d1 "ode_d (Suc 0) x" x S
    proof standard
      fix a assume "a \<in> S"
      with S have "a \<in> Csafe" by auto
      from S_FDERIV[OF \<open>a \<in> S\<close>]
      have "isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl a)" by simp
      then have "isFDERIV DIM('a) [0..<DIM('a)] ode_e (list_of_eucl a)"
        apply (rule isFDERIV_max_Var_congI)
        using safe_max_Var[of x]
        by (auto simp: nth_append)
      then show "(ode has_derivative blinfun_apply (ode_d1 a)) (at a)"
        using \<open>a \<in> Csafe\<close>
        by (rule ode_has_derivative)
    next
      fix i
      interpret linear "ode_d (Suc 0) x"
      proof
        fix y z
        have 1: "((\<lambda>x. ode_d 0 x (y + z) (y + z)) has_derivative ode_d (Suc 0) x (y + z)) (at x)"
          apply (rule ode_d_has_derivative)
          apply (rule assms)
          done
        have *: "ode_d 0 x (y + z) (y + z) = ode_d 0 x y y + ode_d 0 x z z" for x
          by (auto simp: blinfun.bilinear_simps ode_d1_eq[symmetric])
        have 2: "((\<lambda>x. ode_d 0 x (y + z) (y + z)) has_derivative
            ode_d (Suc 0) x y + ode_d (Suc 0) x z) (at x)"
          apply (subst *)
          apply (rule derivative_eq_intros)
            apply (rule ode_d_has_derivative)
            apply fact
           apply (rule ode_d_has_derivative)
           apply fact
          apply (auto simp: blinfun.bilinear_simps)
          done
        from has_derivative_unique[OF 1 2]
        show "ode_d (Suc 0) x (y + z) = ode_d (Suc 0) x y + ode_d (Suc 0) x z"
          by (auto intro!: blinfun_eqI)
      next
        fix r y
        have 1: "((\<lambda>x. ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y)) has_derivative ode_d (Suc 0) x (r *\<^sub>R y)) (at x)"
          by (rule ode_d_has_derivative; fact)
        have *: "ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y) = r *\<^sub>R ode_d 0 x y y" for x
          by (auto simp: blinfun.bilinear_simps ode_d1_eq[symmetric])
        have 2: "((\<lambda>x. ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y)) has_derivative
            r *\<^sub>R ode_d (Suc 0) x y) (at x)"
          apply (subst *)
          apply (rule derivative_eq_intros)
          apply (rule ode_d_has_derivative; fact)
          apply (auto simp: blinfun.bilinear_simps)
          done
        from has_derivative_unique[OF 1 2]
        show "(ode_d (Suc 0) x (r *\<^sub>R y)) = (r *\<^sub>R ode_d (Suc 0) x y)"
          by (auto intro!: blinfun_eqI)
      qed
      show "((\<lambda>x. blinfun_apply (ode_d1 x) i) has_derivative blinfun_apply (ode_d (Suc 0) x i))
          (at x)"
        apply (subst euclidean_representation[of i, symmetric])
        apply (subst (2) euclidean_representation[of i, symmetric])
        apply (auto simp: blinfun.bilinear_simps)
        apply (rule derivative_eq_intros)
         apply (rule derivative_eq_intros)
          apply (subst_tac j = i in ode_d1_eq)
          apply (rule ode_d_has_derivative)
          apply (rule assms)
        apply force
        apply (auto simp: blinfun.bilinear_simps[symmetric]
            intro!: ext euclidean_eqI[where 'a='a] blinfun_euclidean_eqI)
        apply (rule arg_cong[where f="\<lambda>x. x \<bullet> b" for b])
        by (auto simp: sum scaleR)
    next
      show "x \<in> S" "open S" by fact+
    qed
    show ?case
      by (rule symmetric_second_derivative) fact
  qed
qed

lemma ode_d1_has_derivative_safeI:
  assumes "x \<in> Csafe"
  shows "(ode_d1 has_derivative ode_d (Suc 0) x) (at x)"
  apply (rule ode_d1_has_derivative)
  using assms by (auto simp: safe_def)

sublocale c1_on_open_euclidean ode ode_d1 Csafe
  by unfold_locales
    (auto simp: continuous_on_eq_continuous_within at_within_open[OF _ open_safe]
      intro!: derivative_eq_intros  continuous_at_imp_continuous_on open_safe
        ode_has_derivative_safeI continuous_blinfun_componentwiseI
        has_derivative_continuous ode_d1_has_derivative_safeI)

definition ivlflows ::
    "'a::executable_euclidean_space sctn set
     \<Rightarrow> (('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set
         \<Rightarrow> ('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set \<times> ('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set)
        \<Rightarrow> ('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set \<Rightarrow> 'a sctn \<Rightarrow> bool"
where "ivlflows stops stopcont trap rsctn =
  (\<forall>ivl. ivl \<subseteq> \<Union>(plane_of ` stops) \<times> UNIV \<longrightarrow>
      ivl \<subseteq> (snd (stopcont ivl)) \<and>
      fst (stopcont ivl) \<subseteq> snd (stopcont ivl) \<and>
      (fst (stopcont ivl)) \<subseteq> sbelow_halfspace rsctn \<times> UNIV \<and>
      (snd (stopcont ivl)) \<subseteq> sbelow_halfspace rsctn \<times> UNIV \<and>
      flowsto (ivl) {0..} ((snd (stopcont ivl))) ((fst (stopcont ivl)) \<union> trap))"

lift_definition ode_d2::"'a::executable_euclidean_space \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'a" is "\<lambda>x.
  if x \<in> Csafe then ode_d 1 x else (\<lambda>_. 0)"
  by (auto intro!: has_derivative_bounded_linear ode_d1_has_derivative)

definition ode_na::"real \<times> _ \<Rightarrow> _" where "ode_na = (\<lambda>a. ode (snd a))"

definition ode_d_na::"real \<times> _ \<Rightarrow> (real \<times> _) \<Rightarrow>\<^sub>L _" where "ode_d_na = (\<lambda>tx. ode_d1 (snd tx) o\<^sub>L snd_blinfun)"
definition ode_d2_na::"real \<times> _ \<Rightarrow> (real \<times> _) \<Rightarrow>\<^sub>L (real \<times> _) \<Rightarrow>\<^sub>L _" where
  "ode_d2_na = (\<lambda>tx. flip_blinfun (flip_blinfun (ode_d2 (snd tx) o\<^sub>L snd_blinfun) o\<^sub>L snd_blinfun))"

definition "euler_incr_fas' D = (map fold_const_fa (euler_incr_fas (map floatarith.Var [0..<D]) (floatarith.Var (D))
      (map floatarith.Var [Suc D..<Suc (2*D)])))"
definition "euler_fas' D = (map fold_const_fa (euler_fas  (map floatarith.Var [0..<D])
    (floatarith.Var (2*D)) (map floatarith.Var [D..<2*D])))"
definition "rk2_fas' D = (map fold_const_fa (rk2_fas
    (floatarith.Var (2*D))
    (map floatarith.Var [0..<D])
    (floatarith.Var (2*D+1))
    (map floatarith.Var [D..<2*D])
    (floatarith.Var (2*D+2))))"
lemma [autoref_rules]: "(euler_incr_fas', euler_incr_fas') \<in> nat_rel \<rightarrow> fas_rel"
  "(euler_fas', euler_fas') \<in> nat_rel \<rightarrow> fas_rel"
  "(rk2_fas', rk2_fas') \<in> nat_rel \<rightarrow> fas_rel"
  by auto

definition "solve_poincare_fas n =
  (let D = length ode_e in
  map floatarith.Var [0..<D] @ concat (map (\<lambda>i \<comment> \<open>(row)\<close>. map (\<lambda>j \<comment> \<open>(column)\<close>.
    (if i \<noteq> n then floatarith.Var (D + i * D + j) - (floatarith.Var(D + n * D + j) * (ode_e ! i) / (ode_e ! n))
    else 0)
  ) [0..<D]) [0..<D]))"

end

definition "nonempty X \<longleftrightarrow> X \<noteq> {}"

definition pad_zeroes :: "nat \<Rightarrow> real list set \<Rightarrow> real list set"
  where [simp]: "pad_zeroes n X = (\<lambda>xs. xs @ replicate n (0::real)) ` X"

locale approximate_sets_ode = approximate_sets where ops = ops + ode_operations
  where ode_ops = ode_ops
  for ops:: "'b approximate_set_ops"
    and ode_ops::"ode_ops"
begin

definition "D = (length ode_e)"
definition "ode_slp = slp_of_fas ode_e"
definition "euler_slp = slp_of_fas (euler_fas' D)"
definition "euler_incr_slp = slp_of_fas (euler_incr_fas' D)"
definition "rk2_slp = slp_of_fas (rk2_fas' D)"
definition "solve_poincare_slp = map (\<lambda>i. slp_of_fas (map fold_const_fa (solve_poincare_fas i))) [0..<D]"

definition safe_set
  where "safe_set (X::'a::executable_euclidean_space set) = do {
    b1 \<leftarrow> approx_form_spec safe_form (list_of_eucl ` X);
    b2 \<leftarrow> isFDERIV_spec D [0..<D] ode_e (list_of_eucl ` X);
    RETURN (b1 \<and> b2)
  }"

definition "wd TYPE('a::executable_euclidean_space) \<longleftrightarrow> length ode_e = DIM('a)"
  \<comment> \<open>TODO: should be renamed\<close>

lemma open_safe_form[intro, simp]: "open_form safe_form"
  by (auto simp: safe_form_def)

lemma max_Var_floatariths_ode_e_le: "max_Var_floatariths ode_e \<le> D"
  and max_Var_form_safe_form_le: "max_Var_form safe_form \<le> D"
  using max_Var_ode_expression[of ode_ops] max_Var_form_safe_form_expr[of ode_ops]
  by (auto simp: ode_e_def safe_form_def D_def)

lemma wdD:
  assumes "wd TYPE('a::executable_euclidean_space)"
  shows "length ode_e = DIM('a)" "max_Var_floatariths ode_e \<le> DIM('a)"
    "max_Var_form safe_form \<le> DIM('a)"
    "ode_e \<noteq> []" "D = DIM('a)"
  using assms max_Var_floatariths_ode_e_le max_Var_form_safe_form_le
  by (auto simp: wd_def D_def safe_form_def ode_e_def)

definition "mk_safe (X::'a::executable_euclidean_space set) = do {
    ASSERT (wd TYPE('a));
    s \<leftarrow> safe_set (X:::appr_rel::'a set);
    if s then RETURN (X:::appr_rel) else SUCCEED
  }"

definition
  "mk_safe_coll X = do {
      XS \<leftarrow> (sets_of_coll X);
      FORWEAK XS (RETURN op_empty_coll)
        (\<lambda>x. do {
          s \<leftarrow> mk_safe (x);
          RETURN (mk_coll s)
        })
        (\<lambda>b c. RETURN (b \<union> c))
    }"

definition ode_set::"'a::executable_euclidean_space set \<Rightarrow> 'a set nres" where "ode_set X = do {
  _ \<leftarrow> mk_safe X;
  approx_slp_appr ode_e ode_slp (list_of_eucl ` (X))
  }"

definition
  "Picard_step X0 t0 h X = SPEC (\<lambda>R.
    case R of
      Some R \<Rightarrow>
        nonempty R \<and> compact R \<and> (R \<subseteq> Csafe) \<and>
        (\<forall>x0 \<in> X0. \<forall>h'\<in>{t0 .. t0 + h}. \<forall>phi\<in>cfuncset t0 h' X.
          x0 + integral {t0 .. h'} (\<lambda>t. ode (phi t)) \<in> R)
      | None \<Rightarrow> True)"

lemmas [refine_vcg_def] = approx_form_spec_def isFDERIV_spec_def

lemma safe_set_spec[THEN order.trans, refine_vcg]:
  assumes "wd TYPE('a::executable_euclidean_space)"
  shows "safe_set X \<le> SPEC (\<lambda>r. r \<longrightarrow> (X::'a set) \<subseteq> Csafe)"
  unfolding safe_set_def
  by (refine_vcg) (auto simp del: isnFDERIV.simps simp add: Csafe_def safe_def replicate_eq_list_of_eucl_zero wdD[OF \<open>wd _\<close>])

definition Picard_step_ivl :: "'a::executable_euclidean_space set \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a set \<Rightarrow> 'a set option nres" where
  "Picard_step_ivl X0 t0 h X = do {
    ASSERT (0 \<le> h);
    ASSERT (wd TYPE('a));
    let H = lv_ivl [0] [h];
    let D = DIM('a);
    let env = concat ` listset [list_of_eucl ` X0, H, list_of_eucl ` X];
    env \<leftarrow> approx_slp_spec (euler_incr_fas' D) D euler_incr_slp env;
    (case env of
      Some env \<Rightarrow>
        do {
          (l, u) \<leftarrow> op_ivl_rep_of_set ((eucl_of_list ` env::'a set));
          ASSERT (l \<le> u);
          r \<leftarrow> mk_safe ({l .. u}:::appr_rel);
          RETURN (Some (r:::appr_rel))
        }
    | None \<Rightarrow> RETURN None)
  }"

definition "do_widening_spec (i::nat) = SPEC (\<lambda>b::bool. True)"

primrec P_iter::"'a::executable_euclidean_space set \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> ('a) set \<Rightarrow> ('a) set option nres" where
  "P_iter X0 h 0 X = do {
    let _ = trace_set (ST ''P_iter failed (0)'') (Some (X));
    RETURN None
  }"
| "P_iter X0 h (Suc i) X = do {
    ASSERT (0 \<le> h);
    (l, u) \<leftarrow> op_ivl_rep_of_set (X);
    ASSERT (l \<le> u);
    ivl \<leftarrow> mk_safe ({l .. u}:::appr_rel);
    X' \<leftarrow> Picard_step_ivl X0 0 h ivl;
    (case X' of
      Some X' \<Rightarrow> do {
        (l', u') \<leftarrow> op_ivl_rep_of_set (X');
        do_widening \<leftarrow> do_widening_spec i;
        let l' = inf l' l - (if do_widening then abs (l' - l) else 0);
        let u' = sup u' u + (if do_widening then abs (u' - u) else 0);
        ASSERT (l' \<le> u');
        ivl' \<leftarrow> mk_safe {l' .. u'};
        if (l \<le> l' \<and> u' \<le> u) then RETURN (Some ivl)
        else P_iter X0 h i ivl'
      }
    | None \<Rightarrow> do {
        let _ = trace_set (ST ''P_iter failed (Picard_step)'') (Some (X));
        RETURN None
      }
    )
  }"

context fixes m::"('a::executable_euclidean_space set \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a set \<Rightarrow> ('a set \<times> 'c) option nres)"
begin

primrec cert_stepsize::
  "'a set \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (real \<times> 'a set \<times> 'a set \<times> 'c) nres"
where
  "cert_stepsize X0 h n 0 = do { let _ = trace_set (ST ''cert_stepsize failed'') (Some (X0)); SUCCEED}"
| "cert_stepsize X0 h n (Suc i) = do {
    (l, u) \<leftarrow> op_ivl_rep_of_set (X0);
    ASSERT (0 \<le> h);
    ASSERT (l \<le> u);
    ivl \<leftarrow> mk_safe {l .. u};
    ASSERT (ivl \<noteq> {});
    X' \<leftarrow> P_iter X0 h n ivl;
    case X' of Some X' \<Rightarrow>
      do {
        r1 \<leftarrow> m X0 h h X';
        r2 \<leftarrow> m X0 0 h X';
        (case (r1, r2) of
          (Some (res, err), Some (res_ivl, _)) \<Rightarrow>
            do {
              _ \<leftarrow> mk_safe res;
              _ \<leftarrow> mk_safe res_ivl;
              RETURN (h, res, res_ivl, err)
            }
        | _ \<Rightarrow>
            do {
              let _ = trace_set (ST ''cert_stepsize method failed'') (Some (X'));
              cert_stepsize X0 (h / 2) n i
            }
       )
      }
    | None \<Rightarrow> cert_stepsize X0 (h / 2) n i
    }"
end

definition "one_step_method m \<longleftrightarrow> (\<forall>X0 CX hl hu. m X0 hl hu CX \<le>
    SPEC (\<lambda>r. case r of None \<Rightarrow> True | Some (res, err) \<Rightarrow> nonempty res \<and>
      (\<forall>x0 \<in> X0. \<forall>h \<in> {hl .. hu}. x0 \<in> Csafe \<longrightarrow> h \<ge> 0 \<longrightarrow> h \<in> existence_ivl0 x0 \<longrightarrow>
      (\<forall>h' \<in> {0 .. h}. flow0 x0 h' \<in> CX) \<longrightarrow> x0 + h *\<^sub>R ode x0 \<in> CX \<longrightarrow> flow0 x0 h \<in> res)))"

definition "one_step X0 h m = do {
  CHECKs ''one_step nonneg'' (0 < h);
  its \<leftarrow> iterations_spec;
  halvs \<leftarrow> halve_stepsizes_spec;
  (h, res, res_ivl, err) \<leftarrow> cert_stepsize m X0 h its halvs;
  ASSERT (0 < h);
  RETURN (h, err, res_ivl, res)
  }"

definition [refine_vcg_def]: "default_reduce_argument_spec = SPEC (\<lambda>x::unit. True)"

definition "euler_step X0 h = one_step X0 h (\<lambda>X0 hl hu CX.
   do {
    let H = lv_ivl [min hl hu] [max hl hu];
    _ \<leftarrow> mk_safe CX;
    let env = concat ` listset [list_of_eucl ` X0, list_of_eucl ` CX, H];
    env \<leftarrow> approx_slp_spec (euler_fas' DIM('a)) (2 * DIM('a)) euler_slp env;
    case env of None \<Rightarrow> RETURN None
    | Some env \<Rightarrow> do {
      let res' = take DIM('a) ` env;
      ASSERT (env_len res' DIM('a));
      let res = (eucl_of_list ` res');
      ASSUME (ncc res);
      let err' = drop DIM('a) ` take (DIM('a) * 2) ` env;
      ASSERT (env_len err' DIM('a));
      let err = (eucl_of_list ` err'::'a::executable_euclidean_space set);
      ra \<leftarrow> default_reduce_argument_spec;
      res \<leftarrow> reduce_spec ra res;
      ASSUME (ncc res);
      s \<leftarrow> safe_set res;
      if s then
      do {
        res \<leftarrow> mk_safe res;
        RETURN (Some (res::'a set, err))
      } else RETURN None
    }
  })"

definition "rk2_step X0 h = one_step X0 h (\<lambda>X0 hl hu CX.
  do {
    let H = lv_ivl [min hl hu] [max hl hu];
    rps \<leftarrow> rk2_param_spec;
    let rkp = lv_ivl [rps] [rps];
    let s2 = lv_ivl [0] [1];
    _ \<leftarrow> mk_safe CX;
    ASSUME (ncc CX);
    let env = concat ` listset [list_of_eucl ` X0, list_of_eucl ` CX, rkp, H, s2];
    env \<leftarrow> approx_slp_spec (rk2_fas' DIM('a)) (2 * DIM('a)) rk2_slp env;
    case env of None \<Rightarrow> RETURN None
    | Some env \<Rightarrow> do {
      let res' = take DIM('a) ` env;
      ASSERT (env_len res' DIM('a));
      let res = (eucl_of_list ` res'::'a::executable_euclidean_space set);
      ASSUME (ncc res);
      let err' = drop DIM('a) ` take (DIM('a) * 2) ` env;
      ASSERT (env_len err' DIM('a));
      let err = (eucl_of_list ` err'::'a set);
      ra \<leftarrow> default_reduce_argument_spec;
      res \<leftarrow> reduce_spec ra res;
      ASSUME (ncc res);
      s \<leftarrow> safe_set res;
      if s then
      do {
        res \<leftarrow> mk_safe res;
        RETURN (Some (res, err))
      } else RETURN None
    }
  })"

definition "choose_step X0 h = do {
  mid \<leftarrow> method_spec;
  (if mid = 2 then rk2_step X0 h else euler_step X0 h)
}"

definition "ode_e' = (ode_e @
  mmult_fa D D D (concat (map (\<lambda>j. map (\<lambda>i.
      (FDERIV_floatarith (ode_e ! j) [0..<D] ((replicate D 0)[i := 1]))) [0..<D]) [0..<D]))
    (map floatarith.Var [D..<D + D*D]))"

definition "transversal_directions f =
  do {
    (I, S) \<leftarrow> op_ivl_rep_of_set f;
    RETURN (sum_list (map (\<lambda>b. (if I \<bullet> b \<le> 0 then if S \<bullet> b \<le> 0 then S \<bullet> b else 0 else if S \<bullet> b \<ge> 0 then I \<bullet> b else 0) *\<^sub>R b)
      (Basis_list::'a::executable_euclidean_space list)))
  }"

definition "intersects_sctns X' sctns = do {
    ASSUME (finite sctns);
    FOREACH\<^bsup>\<lambda>sctns' b. \<not>b \<longrightarrow> X' \<inter> \<Union>(plane_of ` (sctns - sctns')) = {}\<^esup> sctns
          (\<lambda>sctn b. do {b' \<leftarrow> op_intersects ( X') sctn; RETURN (b \<or> b')}) False
   }"

definition "trace_sets s X = do {
    XS \<leftarrow> sets_of_coll (X:::clw_rel (appr_rel)); FORWEAK XS (RETURN ()) (\<lambda>X. RETURN (trace_set s (Some X))) (\<lambda>_ _. RETURN ())
  }"

definition "print_sets s X = do {
    XS \<leftarrow> sets_of_coll (X:::clw_rel (appr_rel)); FORWEAK XS (RETURN ()) (\<lambda>X. RETURN (print_set s (X))) (\<lambda>_ _. RETURN ())
  }"

definition "intersects_sctns_spec_clw R sctns = do {
    Rs \<leftarrow> sets_of_coll ((R:::clw_rel appr_rel):::clw_rel(appr_rel));
    FORWEAK Rs (RETURN False) (\<lambda>R. intersects_sctns R sctns) (\<lambda>a b. RETURN (a \<or> b))
  }"

definition [simp]: "nonneg_reals = ({0..}::real set)"
definition [simp]: "pos_reals = ({0<..}::real set)"

definition "nonzero_component s X n = do {
    I \<leftarrow> Inf_inner X n;
    S \<leftarrow> Sup_inner X n;
    CHECKs s (I > 0 \<or> S < 0)
  }"

definition "disjoints_spec X Y = do {
    Xi \<leftarrow> ivls_of_sets X;
    IS \<leftarrow> inter_overappr (Xi:::clw_rel lvivl_rel) (Y:::clw_rel lvivl_rel);
    RETURN (is_empty IS)
  }"

definition subset_spec_plane :: "'a::executable_euclidean_space set \<Rightarrow> 'a sctn \<Rightarrow> bool nres" where
"subset_spec_plane X sctn = do {
    CHECKs ''subset_spec_plane: not in Basis'' (abs (normal sctn) \<in> set Basis_list);
    (i, s) \<leftarrow> ivl_rep X;
    RETURN (i \<bullet> normal sctn = pstn sctn \<and> s \<bullet> normal sctn = pstn sctn)
  }"

definition "op_eventually_within_sctn X sctn S = do {
    (l, u) \<leftarrow> ivl_rep S;
    (xl, xu) \<leftarrow> op_ivl_rep_of_set X;
    CHECKs (ST ''op_eventually_within_sctn: empty ivl'') (l \<le> u);
    CHECKs (ST ''op_eventually_within_sctn: not in Basis'') (abs (normal sctn) \<in> set Basis_list);
    b \<leftarrow> subset_spec_plane S sctn;
    CHECKs (ST ''op_eventually_within_sctn: subset_spec_plane 1'') b;
    b \<leftarrow> subset_spec_plane ({xl .. xu}:::lvivl_rel) sctn;
    CHECKs (ST ''op_eventually_within_sctn: subset_spec_plane 2'') b;
    RETURN (b \<and> (\<forall>i \<in> set Basis_list - {abs (normal sctn)}. l \<bullet> i < xl \<bullet> i \<and> xu \<bullet> i < u \<bullet> i))
  }"

definition [simp]: "uninfo X = X"

definition [simp]: "op_subset_ivl a b \<longleftrightarrow> a \<subseteq> b"

definition [simp]: "op_eq_ivl a b \<longleftrightarrow> a = b"

abbreviation "iplane_rel \<equiv> \<lambda>A. \<langle>A, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel"
abbreviation "isbelow_rel \<equiv> \<lambda>A. \<langle>A, \<langle>lv_rel\<rangle>sbelow_rel\<rangle>inter_rel"
abbreviation "isbelows_rel \<equiv> \<lambda>A. \<langle>A, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel"

definition [refine_vcg_def]: "get_plane X = SPEC (\<lambda>sctn. X = plane_of sctn)"

definition "tolerate_error Y E =
  do {
    (ei, es) \<leftarrow> op_ivl_rep_of_set (E);
    (yi, ys) \<leftarrow> op_ivl_rep_of_set (Y);
    let ea = sup (abs ei) (abs es);
    let ya = sup (abs yi) (abs ys);
    rtol \<leftarrow> adaptive_rtol_spec;
    atol \<leftarrow> adaptive_atol_spec;
    let errtol = sup (rtol *\<^sub>R ya) (atol *\<^sub>R sum_list Basis_list);
    RETURN (ea \<le> errtol, infnorm ea)
  }"

definition "adapt_stepsize_fa rtol m e h' =
  floatarith.Num (float_of h') *
  floatarith.Powr (floatarith.Num (float_of (rtol)) / floatarith.Num (float_of e))
    (inverse (floatarith.Num (float_of (real_of_nat m) + 1)))"

end

text \<open>With ODE operations for variational equation\<close>

locale approximate_sets_ode' = approximate_sets_ode\<comment> \<open>TODO: this prevents infinite chain of interpretations (?!)\<close>
  where ops = ops
    and ode_ops = ode_ops
  for ops :: "'b approximate_set_ops"
    and ode_ops
begin

lift_definition var_ode_ops::ode_ops is "(ode_e', safe_form)"
  using max_Var_floatariths_ode_e_le max_Var_form_safe_form_le
  by (auto simp: ode_e'_def D_def length_concat o_def sum_list_triv
      intro!: max_Var_floatariths_mmult_fa[le] max_Var_floatariths_concat max_Var_floatariths_mapI
      max_Var_floatarith_FDERIV_floatarith[le] max_Var_floatariths_list_update
      max_Var_floatariths_replicateI
      max_Var_floatarith_le_max_Var_floatariths_nth[le])

sublocale var: approximate_sets_ode where ode_ops = var_ode_ops
  by unfold_locales

end

lifting_update ode_ops.lifting
lifting_forget ode_ops.lifting

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Chain
  imports Nominal
begin

lemma pt_set_nil:
  fixes Xs :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "([]::'x prm)\<bullet>Xs = Xs"
by(auto simp add: perm_set_def pt1[OF pt])

lemma pt_set_append:
  fixes pi1 :: "'x prm"
  and   pi2 :: "'x prm"
  and   Xs  :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "(pi1@pi2)\<bullet>Xs = pi1\<bullet>(pi2\<bullet>Xs)"
by(auto simp add: perm_set_def pt2[OF pt])

lemma pt_set_prm_eq:
  fixes pi1 :: "'x prm"
  and   pi2 :: "'x prm"
  and   Xs  :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "pi1 \<triangleq> pi2  \<Longrightarrow> pi1\<bullet>Xs = pi2\<bullet>Xs"
by(auto simp add: perm_set_def pt3[OF pt])

lemma pt_set_inst:
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "pt TYPE('a set) TYPE('x)"
apply(simp add: pt_def pt_set_nil[OF pt, OF at] pt_set_append[OF pt, OF at])
apply(clarify)
by(rule pt_set_prm_eq[OF pt, OF at])

lemma pt_ball_eqvt:
  fixes pi :: "'a prm"
  and   Xs :: "'b set"
  and   P :: "'b \<Rightarrow> bool"

  assumes pt: "pt TYPE('b) TYPE('a)"
  and     at: "at TYPE('a)"

  shows "(pi \<bullet> (\<forall>x \<in> Xs. P x)) = (\<forall>x \<in> (pi \<bullet> Xs). pi \<bullet> P (rev pi \<bullet> x))"
apply(auto simp add: perm_bool)
apply(drule_tac pi="rev pi" in pt_set_bij2[OF pt, OF at])
apply(simp add: pt_rev_pi[OF pt_set_inst[OF pt, OF at], OF at])
apply(drule_tac pi="pi" in pt_set_bij2[OF pt, OF at])
apply(erule_tac x="pi \<bullet> x" in ballE)
apply(simp add: pt_rev_pi[OF pt, OF at])
by simp

lemma perm_cart_prod:
  fixes Xs :: "'b set"
  and   Ys :: "'c set"
  and   p  :: "'a prm"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"

  shows "(p \<bullet> (Xs \<times> Ys)) = (((p \<bullet> Xs) \<times> (p \<bullet> Ys))::(('b \<times> 'c) set))"
by(auto simp add: perm_set_def)

lemma supp_member:
  fixes Xs :: "'b set"
  and   x  :: 'a

  assumes pt: "pt TYPE('b) TYPE('a)"
  and     at: "at TYPE('a)"
  and     fs: "fs TYPE('b) TYPE('a)"
  and     "finite Xs"
  and     "x \<in> ((supp Xs)::'a set)"

  obtains X where "(X::'b) \<in> Xs" and "x \<in> supp X"
proof -
  from `finite Xs` `x \<in> supp Xs` have "\<exists>X::'b. (X \<in> Xs) \<and> (x \<in> (supp X))"
  proof(induct rule: finite_induct)
    case empty
    from `x \<in> ((supp {})::'a set)` have False
      by(simp add: supp_set_empty)
    thus ?case by simp
  next
    case(insert y Xs)
    show ?case
    proof(case_tac "x \<in> supp y")
      assume "x \<in> supp y"
      thus ?case by force
    next
      assume "x \<notin> supp y"
      with `x \<in> supp(insert y Xs)` have "x \<in> supp Xs"
        by(simp add: supp_fin_insert[OF pt, OF at, OF fs, OF `finite Xs`])
      with `x \<in> supp Xs \<Longrightarrow> \<exists>X. X \<in> Xs \<and> x \<in> supp X`
      show ?case by force
    qed
  qed
  with `\<And>X. \<lbrakk>X \<in> Xs; x \<in> supp X\<rbrakk> \<Longrightarrow> thesis`
  show ?thesis by blast
qed

lemma supp_cart_prod_empty[simp]:
  fixes Xs :: "'b set"

  shows "supp (Xs \<times> {}) = ({}::'a set)"
  and   "supp ({} \<times> Xs) = ({}::'a set)"
by(auto simp add: supp_set_empty)

lemma supp_cart_prod:
  fixes Xs :: "'b set"
  and   Ys :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "((supp (Xs \<times> Ys))::'a set) = ((supp Xs) \<union> (supp Ys))"
proof -
  from f1 f2 have f3: "finite(Xs \<times> Ys)" by simp
  show ?thesis
    apply(simp add: supp_of_fin_sets[OF pt_prod_inst[OF pt1, OF pt2], OF at, OF fs_prod_inst[OF fs1, OF fs2], OF f3] supp_prod)
    apply(rule equalityI)
    using Union_included_in_supp[OF pt1, OF at, OF fs1, OF f1] Union_included_in_supp[OF pt2, OF at, OF fs2, OF f2]
    apply(force simp add: supp_prod)
    using a b
    apply(auto simp add: supp_prod)
    using supp_member[OF pt1, OF at, OF fs1, OF f1]
    apply blast
    using supp_member[OF pt2, OF at, OF fs2, OF f2]
    by blast
qed

lemma fresh_cart_prod:
  fixes x  :: 'a
  and   Xs :: "'b set"
  and   Ys :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "(x \<sharp> (Xs \<times> Ys)) = (x \<sharp> Xs \<and> x \<sharp> Ys)"
using assms
by(simp add: supp_cart_prod fresh_def)

lemma fresh_star_cart_prod:
  fixes Zs   :: "'a set"
  and   xvec :: "'a list"
  and   Xs   :: "'b set"
  and   Ys   :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "(Zs \<sharp>* (Xs \<times> Ys)) = (Zs \<sharp>* Xs \<and> Zs \<sharp>* Ys)"
  and   "(xvec \<sharp>* (Xs \<times> Ys)) = (xvec \<sharp>* Xs \<and> xvec \<sharp>* Ys)"
using assms
by(force simp add: fresh_cart_prod fresh_star_def)+

lemma permCommute:
  fixes p  :: "'a prm"
  and   q  :: "'a prm"
  and   P  :: 'x
  and   Xs :: "'a set"
  and   Ys :: "'a set"

  assumes pt: "pt TYPE('x) TYPE('a)"
  and     at: "at TYPE('a)"
  and     a: "(set p) \<subseteq> Xs \<times> Ys"
  and     b: "Xs \<sharp>* q"
  and     c: "Ys \<sharp>* q"

  shows "p \<bullet> q \<bullet> P = q \<bullet> p \<bullet> P"
proof -
  have "p \<bullet> q \<bullet> P = (p \<bullet> q) \<bullet> p \<bullet> P"
    by(rule pt_perm_compose[OF pt, OF at])
  moreover from at have "pt TYPE('a) TYPE('a)"
    by(rule at_pt_inst)
  hence "pt TYPE(('a \<times> 'a) list) TYPE('a)"
    by(force intro: pt_prod_inst pt_list_inst)
  hence "p \<bullet> q = q" using at a b c
    by(rule pt_freshs_freshs)
  ultimately show ?thesis by simp
qed

definition
  distinctPerm :: "'a prm \<Rightarrow> bool" where
  "distinctPerm p \<equiv> distinct((map fst p)@(map snd p))"

lemma at_set_avoiding_aux':
  fixes Xs::"'a set"
  and   As::"'a set"
  assumes at: "at TYPE('a)"
  and     a: "finite Xs"
  and     b: "Xs \<subseteq> As"
  and     c: "finite As"
  and     d: "finite ((supp c)::'a set)"
  shows "\<exists>(Ys::'a set) (pi::'a prm). Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> (pi\<bullet>Xs=Ys) \<and>
          set pi \<subseteq> Xs \<times> Ys \<and> finite Ys \<and> (distinctPerm pi)"
using a b c
proof (induct)
  case empty
  have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
  moreover
  have "({}::'a set) \<inter> As = {}" by simp
  moreover
  have "([]::'a prm)\<bullet>{} = ({}::'a set)"
    by(rule pt1) (metis Nominal.pt_set_inst at at_pt_inst)
  moreover
  have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
  moreover
  have "finite ({}::'a set)" by simp
  moreover have "distinctPerm([]::'a prm)"
    by(simp add: distinctPerm_def)
  ultimately show ?case by blast
next
  case (insert x Xs)
  then have ih: "\<exists>Ys pi. Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> pi\<bullet>Xs = Ys \<and> set pi \<subseteq> Xs \<times> Ys \<and> finite Ys \<and> distinctPerm pi" by simp
  then obtain Ys pi where a1: "Ys\<sharp>*c" and a2: "Ys \<inter> As = {}" and a3: "(pi::'a prm)\<bullet>Xs = Ys" and
                          a4: "set pi \<subseteq> Xs \<times> Ys" and a5: "finite Ys"
                      and a6: "distinctPerm pi" by blast
  have b: "x\<notin>Xs" by fact
  have d1: "finite As" by fact
  have d2: "finite Xs" by fact
  have d3: "insert x Xs \<subseteq> As" by fact
  have d4: "finite((supp pi)::'a set)"
    by(induct pi)
      (auto simp add: supp_list_nil supp_prod at_fin_set_supp[OF at]
                      supp_list_cons at_supp[OF at])
  have "\<exists>y::'a. y\<sharp>(c,x,Ys,As,pi)" using d d1 a5 d4
    by (rule_tac at_exists_fresh'[OF at])
       (simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at])
  then obtain y::"'a" where  e: "y\<sharp>(c,x,Ys,As,pi)" by blast
  have "({y}\<union>Ys)\<sharp>*c" using a1 e by (simp add: fresh_star_def)
  moreover
  have "({y}\<union>Ys)\<inter>As = {}" using a2 d1 e by (simp add: fresh_prod at_fin_set_fresh[OF at])
  moreover
  have "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys"
  proof -
    have eq: "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
    proof -
      have "(pi\<bullet>x)\<sharp>Ys" using a3[symmetric] b d2
        by(simp add: pt_fresh_bij[OF pt_set_inst, OF at_pt_inst[OF at], OF at, OF at]
                     at_fin_set_fresh[OF at d2])
      moreover
      have "y\<sharp>Ys" using e by simp
      ultimately show "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
        by (simp add: pt_fresh_fresh[OF pt_set_inst, OF at_pt_inst[OF at], OF at, OF at])
    qed
    have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
      by (simp add: pt2[symmetric, OF pt_set_inst, OF at_pt_inst[OF at], OF at])
    also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
      by (simp only: union_eqvt perm_set_def at_calc[OF at])(auto)
    also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>Ys)" using a3 by simp
    also have "\<dots> = {y}\<union>Ys" using eq by simp
    finally show "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys" by auto
  qed
  moreover
  have "pi\<bullet>x=x" using a4 b a2 a3 d3 by (rule_tac at_prm_fresh2[OF at]) (auto)
  then have "set ((pi\<bullet>x,y)#pi) \<subseteq> (insert x Xs) \<times> ({y}\<union>Ys)" using a4 by auto
  moreover
  have "finite ({y}\<union>Ys)" using a5 by simp
  moreover from `Ys \<inter> As = {}` `(insert x Xs) \<subseteq> As` `finite Ys` have "x \<notin> Ys"
    by(auto simp add: fresh_def at_fin_set_supp[OF at])
  with a6 `pi \<bullet> x = x` `x \<notin> Xs` `(set pi) \<subseteq> Xs \<times> Ys` e have "distinctPerm((pi \<bullet> x, y)#pi)"
    apply(auto simp add: distinctPerm_def fresh_prod at_fresh[OF at])
    proof -
      fix a b
      assume "b \<sharp> pi" and "(a, b) \<in> set pi"
      thus False
        by(induct pi)
          (auto simp add: supp_list_cons supp_prod at_supp[OF at] fresh_list_cons fresh_prod at_fresh[OF at])
    next
      fix a b
      assume "a \<sharp> pi" and "(a, b) \<in> set pi"
      thus False
        by(induct pi)
          (auto simp add: supp_list_cons supp_prod at_supp[OF at] fresh_list_cons fresh_prod at_fresh[OF at])
    qed
  ultimately
  show ?case by blast
qed

lemma at_set_avoiding:
  fixes Xs::"'a set"
  assumes at: "at TYPE('a)"
  and     a: "finite Xs"
  and     b: "finite ((supp c)::'a set)"
  obtains pi::"'a prm" where "(pi \<bullet> Xs) \<sharp>* c" and "set pi \<subseteq> Xs \<times> (pi \<bullet> Xs)" and "distinctPerm pi"
  using a b
  by (frule_tac As="Xs" in at_set_avoiding_aux'[OF at]) auto

lemma pt_swap:
  fixes x :: 'a
  and a :: 'x
  and b :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"

  shows "[(a, b)] \<bullet> x = [(b, a)] \<bullet> x"
proof -
  show ?thesis by(simp add: pt3[OF pt] at_ds5[OF at])
qed

atom_decl name

lemma supp_subset:
  fixes Xs :: "'a::fs_name set"
  and   Ys :: "'a::fs_name set"

  assumes "Xs \<subseteq> Ys"
  and     "finite Xs"
  and     "finite Ys"

  shows "(supp Xs) \<subseteq> ((supp Ys)::name set)"
proof(rule subsetI)
  fix x
  assume "x \<in> ((supp Xs)::name set)"
  with `finite Xs` obtain X where "X \<in> Xs" and "x \<in> supp X"
    by(rule supp_member[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
  from `X \<in> Xs` `Xs \<subseteq> Ys` have "X \<in> Ys" by auto
  with `finite Ys` `x \<in> supp X` show "x \<in> supp Ys"
    by(induct rule: finite_induct)
      (auto simp add: supp_fin_insert[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
qed

abbreviation mem_def :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" ("_ mem _" [80, 80] 80)  where
  "x mem xs \<equiv> x \<in> set xs"

lemma memFresh:
  fixes x :: name
  and   p :: "'a::fs_name"
  and   l :: "('a::fs_name) list"

  assumes "x \<sharp> l"
  and     "p mem l"

  shows "x \<sharp> p"
using assms
by(induct l, auto simp add: fresh_list_cons)

lemma memFreshChain:
  fixes xvec :: "name list"
  and   p    :: "'a::fs_name"
  and   l    :: "'a::fs_name list"
  and   Xs   :: "name set"

  assumes "p mem l"

  shows "xvec \<sharp>* l \<Longrightarrow> xvec \<sharp>* p"
  and   "Xs \<sharp>* l \<Longrightarrow> Xs \<sharp>* p"
using assms
by(auto simp add: fresh_star_def intro: memFresh)

lemma fresh_star_list_append[simp]:
  fixes A :: "name list"
  and   B :: "name list"
  and   C :: "name list"

  shows "(A \<sharp>* (B @ C)) = ((A \<sharp>* B) \<and> (A \<sharp>* C))"
by(auto simp add: fresh_star_def fresh_list_append)

lemma unionSimps[simp]:
  fixes Xs :: "name set"
  and   Ys :: "name set"
  and   C  :: "'a::fs_name"

  shows "((Xs \<union> Ys) \<sharp>* C) = ((Xs \<sharp>* C) \<and> (Ys \<sharp>* C))"
by(auto simp add: fresh_star_def)

lemma substFreshAux[simp]:
  fixes C    :: "'a::fs_name"
  and   xvec :: "name list"

  shows "xvec \<sharp>* (supp C - set xvec)"
by(auto simp add: fresh_star_def fresh_def at_fin_set_supp[OF at_name_inst] fs_name1)

lemma fresh_star_perm_app[simp]:
  fixes Xs :: "name set"
  and   xvec :: "name list"
  and   p  :: "name prm"
  and   C  :: "'d::fs_name"

  shows "\<lbrakk>Xs \<sharp>* p; Xs \<sharp>* C\<rbrakk> \<Longrightarrow> Xs \<sharp>* (p \<bullet> C)"
  and   "\<lbrakk>xvec \<sharp>* p; xvec \<sharp>* C\<rbrakk> \<Longrightarrow> xvec \<sharp>* (p \<bullet> C)"
by(auto simp add: fresh_star_def fresh_perm_app)

lemma freshSets[simp]:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   X    :: "name set"
  and   C    :: 'a

  shows "([]::name list) \<sharp>* C"
  and   "([]::name list) \<sharp>* [y].C"
  and   "({}::name set) \<sharp>* C"
  and   "({}::name set) \<sharp>* [y].C"
  and   "((x#xvec) \<sharp>* C) = (x \<sharp> C \<and> xvec \<sharp>* C)"
  and   "((x#xvec) \<sharp>* ([y].C)) = (x \<sharp> ([y].C) \<and> xvec \<sharp>* ([y].C))"
  and   "((insert x X) \<sharp>* C) = (x \<sharp> C \<and> X \<sharp>* C)"
  and   "((insert x X) \<sharp>* ([y].C)) = (x \<sharp> ([y].C) \<and> X \<sharp>* ([y].C))"
by(auto simp add: fresh_star_def)

lemma freshStarAtom[simp]: "(xvec::name list) \<sharp>* (x::name) = x \<sharp> xvec"
by(induct xvec)
  (auto simp add: fresh_list_nil fresh_list_cons fresh_atm)

lemma name_list_set_fresh[simp]:
  fixes xvec :: "name list"
  and   x    :: "'a::fs_name"

  shows "(set xvec) \<sharp>* x = xvec \<sharp>* x"
by(auto simp add: fresh_star_def)

lemma name_list_supp:
  fixes xvec :: "name list"

  shows "set xvec = supp xvec"
proof -
  have "set xvec = supp(set xvec)"
    by(simp add: at_fin_set_supp[OF at_name_inst])
  moreover have "\<dots> = supp xvec"
    by(simp add: pt_list_set_supp[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
  ultimately show ?thesis
    by simp
qed

lemma abs_fresh_list_star:
  fixes xvec :: "name list"
  and   a    :: name
  and   P    :: "'a::fs_name"

  shows "(xvec \<sharp>* [a].P) = ((set xvec) - {a}) \<sharp>* P"
by(induct xvec) (auto simp add: fresh_star_def abs_fresh)

lemma abs_fresh_set_star:
  fixes X :: "name set"
  and   a :: name
  and   P :: "'a::fs_name"

  shows "(X \<sharp>* [a].P) = (X - {a}) \<sharp>* P"
by(auto simp add: fresh_star_def abs_fresh)

lemmas abs_fresh_star = abs_fresh_list_star abs_fresh_set_star

lemma abs_fresh_list_star'[simp]:
  fixes xvec :: "name list"
  and   a    :: name
  and   P    :: "'a::fs_name"

  assumes "a \<sharp> xvec"

  shows "xvec \<sharp>* [a].P = xvec \<sharp>* P"
using assms
by(induct xvec) (auto simp add: abs_fresh fresh_list_cons fresh_atm)

lemma freshChainSym[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"

  shows   "xvec \<sharp>* yvec = yvec \<sharp>* xvec"
using assms
by(auto simp add: fresh_star_def fresh_def name_list_supp)

lemmas [eqvt] = perm_cart_prod[OF pt_name_inst, OF pt_name_inst, OF at_name_inst]

lemma name_set_avoiding:
  fixes c :: "'a::fs_name"
  and   X :: "name set"

  assumes "finite X"
  and     "\<And>pi::name prm. \<lbrakk>(pi \<bullet> X) \<sharp>* c; distinctPerm pi; set pi \<subseteq> X \<times> (pi \<bullet> X)\<rbrakk> \<Longrightarrow> thesis"

  shows thesis
using assms
by(rule_tac c=c in at_set_avoiding[OF at_name_inst]) (simp_all add: fs_name1)

lemmas simps[simp] = fresh_atm fresh_prod
                     pt3[OF pt_name_inst, OF at_ds1, OF at_name_inst]
                     pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]
                     pt_rev_pi[OF pt_name_inst, OF at_name_inst]
                     pt_pi_rev[OF pt_name_inst, OF at_name_inst]

lemmas name_supp_cart_prod = supp_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]
lemmas name_fresh_cart_prod = fresh_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]
lemmas name_fresh_star_cart_prod = fresh_star_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]

lemmas name_swap_bij[simp] = pt_swap_bij[OF pt_name_inst, OF at_name_inst]
lemmas name_swap = pt_swap[OF pt_name_inst, OF at_name_inst]
lemmas name_set_fresh_fresh[simp] = pt_freshs_freshs[OF pt_name_inst, OF at_name_inst]
lemmas list_fresh[simp] = fresh_list_nil fresh_list_cons fresh_list_append

definition  eqvt :: "'a::fs_name set \<Rightarrow> bool" where
                  "eqvt X \<equiv> \<forall>x \<in> X. \<forall>p::name prm. p \<bullet> x \<in> X"

lemma eqvtUnion[intro]:
  fixes Rel  :: "('d::fs_name) set"
  and   Rel' :: "'d set"

  assumes EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "eqvt (Rel \<union> Rel')"
using assms
by(force simp add: eqvt_def)

lemma eqvtPerm[simp]:
  fixes X :: "('d::fs_name) set"
  and   x :: name
  and   y :: name

  assumes "eqvt X"

  shows "([(x, y)] \<bullet> X) = X"
using assms
apply(auto simp add: eqvt_def)
apply(erule_tac x="[(x, y)] \<bullet> xa" in ballE)
apply(erule_tac x="[(x, y)]" in allE)
apply simp
apply(drule_tac pi="[(x, y)]" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply simp
apply(erule_tac x=xa in ballE)
apply(erule_tac x="[(x, y)]" in allE)
apply(drule_tac pi="[(x, y)]" and x="[(x, y)] \<bullet> xa" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply simp
by simp

lemma eqvtI:
  fixes X :: "'d::fs_name set"
  and   x :: 'd
  and   p :: "name prm"

  assumes "eqvt X"
  and     "x \<in> X"

  shows "(p \<bullet> x) \<in> X"
using assms
by(unfold eqvt_def) auto

lemma fresh_star_list_nil[simp]:
  fixes xvec :: "name list"
  and   Xs   :: "name set"

  shows "xvec \<sharp>* []"
  and   "Xs \<sharp>* []"
by(auto simp add: fresh_star_def)

lemma fresh_star_list_cons[simp]:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   x    :: "'a::fs_name"
  and   xs   :: "'a list"

  shows "(xvec \<sharp>* (x#xs)) = ((xvec \<sharp>* x) \<and> xvec \<sharp>* xs)"
  and   "(Xs \<sharp>* (x#xs)) = ((Xs \<sharp>* x) \<and> (Xs \<sharp>* xs))"
by(auto simp add: fresh_star_def)

lemma freshStarPair[simp]:
  fixes X    :: "name set"
  and   xvec :: "name list"
  and   x    :: "'a::fs_name"
  and   y    :: "'b::fs_name"

  shows "(X \<sharp>* (x, y)) = (X \<sharp>* x \<and> X \<sharp>* y)"
  and   "(xvec \<sharp>* (x, y)) = (xvec \<sharp>* x \<and> xvec \<sharp>* y)"
by(auto simp add: fresh_star_def)
lemma name_list_avoiding:
  fixes c    :: "'a::fs_name"
  and   xvec :: "name list"

  assumes "\<And>pi::name prm. \<lbrakk>(pi \<bullet> xvec) \<sharp>* c; distinctPerm pi; set pi \<subseteq> (set xvec) \<times> (set (pi \<bullet> xvec))\<rbrakk> \<Longrightarrow> thesis"

  shows thesis
proof -
  have "finite(set xvec)" by simp
  thus ?thesis using assms
    by(rule name_set_avoiding) (auto simp add: eqvts fresh_star_def)
qed

lemma distinctPermSimps[simp]:
  fixes p :: "name prm"
  and   a :: name
  and   b :: name

  shows "distinctPerm([]::name prm)"
  and   "(distinctPerm((a, b)#p)) = (distinctPerm p \<and> a \<noteq> b \<and> a \<sharp> p \<and> b \<sharp> p)"
apply(simp add: distinctPerm_def)
apply(induct p)
apply(unfold distinctPerm_def)
apply(clarsimp)
apply(rule iffI, erule iffE)
by(clarsimp)+

lemma map_eqvt[eqvt]:
  fixes p   :: "name prm"
  and   lst :: "'a::pt_name list"

  shows "(p \<bullet> (map f lst)) = map (p \<bullet> f) (p \<bullet> lst)"
apply(induct lst, auto)
by(simp add: pt_fun_app_eq[OF pt_name_inst, OF at_name_inst])

lemma consPerm:
  fixes x :: name
  and   y :: name
  and   p :: "name prm"
  and   C :: "'a::pt_name"

  shows "((x, y)#p) \<bullet> C = [(x, y)] \<bullet> p \<bullet> C"
by(simp add: pt2[OF pt_name_inst, THEN sym])

simproc_setup consPerm ("((x, y)#p) \<bullet> C") = {*
  fn _ => fn _ => fn ct =>
     case term_of ct of
        Const (@{const_name perm}, _ ) $ (Const (@{const_name Cons}, _) $ _ $ p) $ _ =>
              (case p of Const (@{const_name Nil}, _) => NONE
                       | _ => SOME(mk_meta_eq @{thm consPerm}))
      | _ => NONE
*}

lemma distinctEqvt[eqvt]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "(p \<bullet> (distinct xs)) = distinct (p \<bullet> xs)"
by(induct xs) (auto simp add: eqvts)

lemma distinctClosed[simp]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "distinct (p \<bullet> xs) = distinct xs"
apply(induct xs)
apply(auto simp add: eqvts)
apply(drule_tac pi=p in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply(simp add: eqvts)
apply(drule_tac pi="rev p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
by(simp add: eqvts)

lemma lengthEqvt[eqvt]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "p \<bullet> (length xs) = length (p \<bullet> xs)"
by(induct xs) (auto simp add: eqvts)

lemma lengthClosed[simp]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "length (p \<bullet> xs) = length xs"
by(induct xs) (auto simp add: eqvts)

lemma subsetEqvt[eqvt]:
  fixes p :: "name prm"
  and   S :: "('a::pt_name) set"
  and   T :: "('a::pt_name) set"

  shows "(p \<bullet> (S \<subseteq> T)) = ((p \<bullet> S) \<subseteq> (p \<bullet> T))"
by(rule pt_subseteq_eqvt[OF pt_name_inst, OF at_name_inst])

lemma subsetClosed[simp]:
  fixes p :: "name prm"
  and   S :: "('a::pt_name) set"
  and   T :: "('a::pt_name) set"

  shows "((p \<bullet> S) \<subseteq> (p \<bullet> T)) = (S \<subseteq> T)"
apply auto
apply(drule_tac pi=p in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply(insert pt_set_bij[OF pt_name_inst, OF at_name_inst])
apply auto
apply(drule_tac pi="rev p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply auto
apply(subgoal_tac "rev p \<bullet> x \<in> T")
apply auto
apply(drule_tac pi="p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply auto
apply(drule_tac pi="p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
by auto

  shows "(set (p \<bullet> xvec) \<subseteq> supp (p \<bullet> P)) = (set xvec \<subseteq> supp P)"
by(simp add: eqvts[THEN sym])

lemma memEqvt[eqvt]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   xs :: "('a::pt_name) list"

  shows "(p \<bullet> (x mem xs)) = ((p \<bullet> x) mem (p \<bullet> xs))"
by(induct xs)
  (auto simp add: pt_bij[OF pt_name_inst, OF at_name_inst] eqvts)

lemma memClosed[simp]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   xs :: "('a::pt_name) list"

  shows "(p \<bullet> x) mem (p \<bullet> xs) = (x mem xs)"
proof -
  have "x mem xs = p \<bullet> (x mem xs)"
    by(case_tac "x mem xs") auto
  thus ?thesis by(simp add: eqvts)
qed

lemma memClosed'[simp]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   y  :: "'b::pt_name"
  and   xs :: "('a \<times>  'b) list"

  shows "((p \<bullet> x, p \<bullet> y) mem (p \<bullet> xs)) = ((x, y) mem xs)"
apply(subgoal_tac "((x, y) mem xs) = (p \<bullet> (x, y)) mem (p \<bullet> xs)")
apply force
by(force simp del: eqvts)

lemma freshPerm:
  fixes x :: name
  and   p :: "name prm"

  assumes "x \<sharp> p"

  shows "p \<bullet> x = x"
using assms
apply(rule_tac pt_pi_fresh_fresh[OF pt_name_inst, OF at_name_inst])
by(induct p, auto simp add: fresh_list_cons fresh_prod)

lemma freshChainPermSimp:
  fixes xvec :: "name list"
  and   p    :: "name prm"

  assumes "xvec \<sharp>* p"

  shows "p \<bullet> xvec = xvec"
  and   "rev p \<bullet> xvec = xvec"
using assms
by(induct xvec) (auto simp add: freshPerm pt_bij1[OF pt_name_inst, OF at_name_inst, THEN sym])

lemma freshChainAppend[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   C    :: "'a::fs_name"

  shows "(xvec@yvec) \<sharp>* C = ((xvec \<sharp>* C) \<and> (yvec \<sharp>* C))"
by(force simp add: fresh_star_def)

lemma subsetFresh:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   C    :: "'d::fs_name"

  assumes "set xvec \<subseteq> set yvec"
  and     "yvec \<sharp>* C"

  shows "xvec \<sharp>* C"
using assms
by(auto simp add: fresh_star_def)

lemma distinctPermCancel[simp]:
  fixes p :: "name prm"
  and   T :: "'a::pt_name"

  assumes "distinctPerm p"

  shows "(p \<bullet> (p \<bullet> T)) = T"
using assms
proof(induct p)
  case Nil
  show ?case by simp
next
  case(Cons a p)
  thus ?case
  proof(case_tac a, auto)
    fix a b
    assume "(a::name) \<sharp> (p::name prm)" "b \<sharp> p" "p \<bullet> p \<bullet> T = T" "a \<noteq> b"
    thus "[(a, b)] \<bullet> p \<bullet> [(a, b)] \<bullet> p \<bullet> T = T"
      by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst]) simp
  qed
qed

fun composePerm :: "name list \<Rightarrow> name list \<Rightarrow> name prm"
where
  Base:  "composePerm [] [] = []"
| Step:  "composePerm (x#xs) (y#ys) = (x, y)#(composePerm xs ys)"
| Empty: "composePerm _ _= []"

lemma composePermInduct[consumes 1, case_names cBase cStep]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   P    :: "name list \<Rightarrow> name list \<Rightarrow> bool"

  assumes L: "length xvec = length yvec"
  and     rBase: "P [] []"
  and     rStep: "\<And>x xvec y yvec. \<lbrakk>length xvec = length yvec; P xvec yvec\<rbrakk> \<Longrightarrow> P (x # xvec) (y # yvec)"

  shows "P xvec yvec"
using assms
by(induct rule: composePerm.induct) auto

lemma composePermEqvt[eqvt]:
  fixes p    :: "name prm"
  and   xvec :: "name list"
  and   yvec :: "name list"

  shows "(p \<bullet> (composePerm xvec yvec)) = composePerm (p \<bullet> xvec) (p \<bullet> yvec)"
by(induct xvec yvec rule: composePerm.induct) auto

abbreviation
  composePermJudge ("[_ _] \<bullet>\<^sub>v _" [80, 80, 80] 80) where "[xvec yvec] \<bullet>\<^sub>v p \<equiv> (composePerm xvec yvec) \<bullet> p"

abbreviation
  composePermInvJudge ("[_ _]\<^sup>- \<bullet>\<^sub>v _" [80, 80, 80] 80) where "[xvec yvec]\<^sup>- \<bullet>\<^sub>v p \<equiv> (rev (composePerm xvec yvec)) \<bullet> p"

lemma permChainSimps[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   perm :: "name prm"
  and   p    :: "'a::pt_name"

  shows "((composePerm xvec yvec) @ perm) \<bullet> p = [xvec yvec] \<bullet>\<^sub>v (perm \<bullet> p)"
by(simp add: pt2[OF pt_name_inst])

lemma permChainEqvt[eqvt]:
  fixes p    :: "name prm"
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: "'a::pt_name"

  shows "(p \<bullet> ([xvec yvec] \<bullet>\<^sub>v x)) = [(p \<bullet> xvec) (p \<bullet> yvec)] \<bullet>\<^sub>v (p \<bullet> x)"
  and   "(p \<bullet> ([xvec yvec]\<^sup>- \<bullet>\<^sub>v x)) = [(p \<bullet> xvec) (p \<bullet> yvec)]\<^sup>- \<bullet>\<^sub>v (p \<bullet> x)"
by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst], simp add: eqvts rev_eqvt)+

lemma permChainBij:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"
  and   q    :: "'a::pt_name"

  assumes "length xvec = length yvec"

  shows "(([xvec yvec] \<bullet>\<^sub>v p) = ([xvec yvec] \<bullet>\<^sub>v q)) = (p = q)"
  and   "(([xvec yvec]\<^sup>- \<bullet>\<^sub>v p) = ([xvec yvec]\<^sup>- \<bullet>\<^sub>v q)) = (p = q)"
using assms
by(induct rule: composePermInduct)
  (auto simp add: pt_bij[OF pt_name_inst, OF at_name_inst])

lemma permChainAppend:
  fixes xvec1 :: "name list"
  and   yvec1 :: "name list"
  and   xvec2 :: "name list"
  and   yvec2 :: "name list"
  and   p     :: "'a::pt_name"

  assumes "length xvec1 = length yvec1"

  shows "([(xvec1@xvec2) (yvec1@yvec2)] \<bullet>\<^sub>v p) = [xvec1 yvec1] \<bullet>\<^sub>v [xvec2 yvec2] \<bullet>\<^sub>v p"
  and   "([(xvec1@xvec2) (yvec1@yvec2)]\<^sup>- \<bullet>\<^sub>v p) = [xvec2 yvec2]\<^sup>- \<bullet>\<^sub>v [xvec1 yvec1]\<^sup>- \<bullet>\<^sub>v p"
using assms
by(induct arbitrary: p rule: composePermInduct, auto) (simp add: pt2[OF pt_name_inst])

lemma calcChainAtom:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name

  assumes "length xvec = length yvec"
  and     "x \<sharp> xvec"
  and     "x \<sharp> yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v x = x"
using assms
by(induct rule: composePermInduct, auto)

lemma calcChainAtomRev:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name

  assumes "length xvec = length yvec"
  and     "x \<sharp> xvec"
  and     "x \<sharp> yvec"

  shows "[xvec yvec]\<^sup>- \<bullet>\<^sub>v x = x"
using assms
by(induct rule: composePermInduct, auto)
  (auto simp add: pt2[OF pt_name_inst] fresh_list_cons calc_atm)

lemma permChainFresh[simp]:
  fixes x    :: name
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "x \<sharp> yvec"
  and     "length xvec = length yvec"

  shows "x \<sharp> [xvec yvec] \<bullet>\<^sub>v p = x \<sharp> p"
  and   "x \<sharp> [xvec yvec]\<^sup>- \<bullet>\<^sub>v p = x \<sharp> p"
using assms
by(auto simp add: fresh_left calcChainAtomRev calcChainAtom)

lemma chainFreshFresh:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "y \<sharp> xvec"

  shows "xvec \<sharp>* ([(x, y)] \<bullet> p) = (xvec \<sharp>* p)"
using assms
by(induct xvec) (auto simp add: fresh_list_cons fresh_left)

lemma permChainFreshFresh:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "xvec \<sharp>* p"
  and     "yvec \<sharp>* p"
  and     "length xvec = length yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v p = p"
  and   "[xvec yvec]\<^sup>- \<bullet>\<^sub>v p = p"
using assms
by(induct rule: composePerm.induct, auto) (simp add: pt2[OF pt_name_inst])

lemma setFresh[simp]:
  fixes x    :: name
  and   xvec :: "name list"

  shows "x \<notin> set xvec = x \<sharp> xvec"
by(simp add: name_list_supp fresh_def)

lemma calcChain:
  fixes xvec :: "name list"
  and   yvec :: "name list"

  assumes "yvec \<sharp>* xvec"
  and     "length xvec = length yvec"
  and     "distinct xvec"
  and     "distinct yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v xvec = yvec"
using assms
by(induct xvec yvec rule: composePerm.induct, auto)
  (subst consPerm, simp add: calcChainAtom calc_atm name_list_supp fresh_def[symmetric])+

lemma freshChainPerm:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name
  and   C    :: "'a::pt_name"

  assumes "length xvec = length yvec"
  and     "yvec \<sharp>* C"
  and     "xvec \<sharp>* yvec"
  and     "x mem xvec"
  and     "distinct yvec"

  shows "x \<sharp> [xvec yvec] \<bullet>\<^sub>v C"
using assms
proof(induct rule: composePermInduct)
  case cBase
  have "x mem []" by fact
  hence False by simp
  thus ?case by simp
next
  case(cStep x' xvec y yvec)
  have "(y # yvec) \<sharp>* C" by fact
  hence yFreshC: "y \<sharp> C" and yvecFreshp: "yvec \<sharp>* C" by simp+
  have "(x' # xvec) \<sharp>* (y # yvec)" by fact
  hence x'ineqy: "x' \<noteq> y" and xvecFreshyvec: "xvec \<sharp>* yvec"
    and x'Freshyvec: "x' \<sharp> yvec" and yFreshxvec: "y \<sharp> xvec"
    by(auto simp add: fresh_list_cons)
  have "distinct (y#yvec)" by fact
  hence yFreshyvec: "y \<sharp> yvec" and yvecDist: "distinct yvec"
    by simp+
  have L: "length xvec = length yvec" by fact
  have "x \<sharp> [(x', y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
  proof(case_tac "x = x'")
    assume xeqx': "x = x'"
    moreover from yFreshxvec yFreshyvec yFreshC L have "y \<sharp> [xvec yvec] \<bullet>\<^sub>v C"
      by simp
    hence "([(x, y)] \<bullet> y) \<sharp> [(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
      by(rule pt_fresh_bij1[OF pt_name_inst, OF at_name_inst])
    with x'ineqy xeqx' show ?thesis by(simp add: calc_atm)
  next
    assume xineqx': "x \<noteq> x'"
    have "x mem (x' # xvec)" by fact
    with xineqx' have xmemxvec: "x mem xvec" by simp
    moreover have "\<lbrakk>yvec \<sharp>* C; xvec \<sharp>* yvec; x mem xvec; distinct yvec\<rbrakk> \<Longrightarrow> x \<sharp> [xvec yvec] \<bullet>\<^sub>v C" by fact
    ultimately have "x \<sharp> [xvec yvec] \<bullet>\<^sub>v C" using yvecFreshp xvecFreshyvec yvecDist
      by simp
    hence "([(x', y)] \<bullet> x) \<sharp> [(x', y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
      by(rule pt_fresh_bij1[OF pt_name_inst, OF at_name_inst])
    moreover from xmemxvec yFreshxvec have "x \<noteq> y"
      by(induct xvec) (auto simp add: fresh_list_cons)
    ultimately show ?thesis using xineqx' x'ineqy by(simp add: calc_atm)
  qed
  thus ?case by simp
qed

lemma memFreshSimp[simp]:
  fixes y    :: name
  and   yvec :: "name list"

  shows "(\<not>(y mem yvec)) = y \<sharp> yvec"
by(induct yvec)
  (auto simp add: fresh_list_nil fresh_list_cons)

lemma freshChainPerm':
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "length xvec = length yvec"
  and     "yvec \<sharp>* p"
  and     "xvec \<sharp>* yvec"
  and     "distinct yvec"

  shows "xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)"
using assms
proof(induct rule: composePermInduct)
  case cBase
  show ?case by simp
next
  case(cStep x xvec y yvec)
  have "(y # yvec) \<sharp>* p" by fact
  hence yFreshp: "y \<sharp> p" and yvecFreshp: "yvec \<sharp>* p"
    by simp+
  moreover have "(x # xvec) \<sharp>* (y # yvec)" by fact
  hence xineqy: "x \<noteq> y" and xvecFreshyvec: "xvec \<sharp>* yvec"
    and xFreshyvec: "x \<sharp> yvec" and yFreshxvec: "y \<sharp> xvec"
    by(auto simp add: fresh_list_cons)
  have "distinct (y # yvec)" by fact
  hence yFreshyvec: "y \<sharp> yvec" and yvecDist: "distinct yvec"
    by simp+
  have L: "length xvec = length yvec" by fact
  have "\<lbrakk>yvec \<sharp>* p; xvec \<sharp>* yvec; distinct yvec\<rbrakk> \<Longrightarrow> xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)" by fact
  with yvecFreshp xvecFreshyvec yvecDist have IH: "xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)" by simp
  show ?case
  proof(auto)
    from L yFreshp yvecFreshp xineqy xvecFreshyvec yvecDist yFreshyvec yFreshxvec xFreshyvec
    have "x \<sharp> [(x # xvec) (y # yvec)] \<bullet>\<^sub>v p"
      by(rule_tac freshChainPerm) (auto simp add: fresh_list_cons)
    thus "x \<sharp> [(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p" by simp
  next
    show "xvec \<sharp>* ([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p)"
    proof(case_tac "x mem xvec")
      assume "x mem xvec"
      with L yvecFreshp xvecFreshyvec yvecDist xFreshyvec
      have"x \<sharp> [xvec yvec] \<bullet>\<^sub>v p"
        by(rule_tac freshChainPerm) (auto simp add: fresh_list_cons)
      moreover from yFreshxvec yFreshyvec yFreshp L
      have "y \<sharp> [xvec yvec] \<bullet>\<^sub>v p" by simp
      ultimately show ?thesis using IH
        by(subst consPerm) (simp add: perm_fresh_fresh)
    next
      assume "\<not>(x mem xvec)"
      hence xFreshxvec: "x \<sharp> xvec" by simp
      from IH have "([(x, y)] \<bullet> xvec) \<sharp>* ([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p)"
        by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with xFreshxvec yFreshxvec show ?thesis by simp
    qed
  qed
qed

lemma permSym:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "x \<sharp> yvec"
  and     "y \<sharp> xvec"
  and     "y \<sharp> yvec"
  and     "length xvec = length yvec"

  shows "([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p) = [xvec yvec] \<bullet>\<^sub>v [(x, y)] \<bullet> p"
using assms
apply(induct rule: composePerm.induct, auto)
by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst]) simp

lemma distinctPermClosed[simp]:
  fixes p :: "name prm"
  and   q :: "name prm"

  assumes "distinctPerm p"

  shows "distinctPerm(q \<bullet> p)"
using assms
by(induct p) (auto simp add: pt_fresh_bij[OF pt_name_inst, OF at_name_inst] dest: pt_bij4[OF pt_name_inst, OF at_name_inst])

lemma freshStarSimps:
  fixes x  :: name
  and   Xs :: "name set"
  and   Ys :: "name set"
  and   C  :: "'a::fs_name"
  and   p  :: "name prm"

  assumes "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* x"
  and     "Ys \<sharp>* x"

  shows "x \<sharp> (p \<bullet> C) = x \<sharp> C"
using assms
by(subst  pt_fresh_bij[OF pt_name_inst, OF at_name_inst, symmetric, of _ C p]) simp

lemma freshStarChainSimps:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   Ys   :: "name set"
  and   C    :: "'a::fs_name"
  and   p    :: "name prm"

  assumes "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* xvec"
  and     "Ys \<sharp>* xvec"

  shows   "xvec \<sharp>* (p \<bullet> C) = xvec \<sharp>* C"
using assms
by(induct xvec) (auto simp add: freshStarSimps)

lemma permStarFresh:
  fixes xvec :: "name list"
  and   p    :: "name prm"
  and   T    :: "'a::pt_name"

  assumes "xvec \<sharp>* p"

  shows "xvec \<sharp>* (p \<bullet> T) = xvec \<sharp>* T"
using assms
by(induct p) (auto simp add: chainFreshFresh)

lemma swapStarFresh:
  fixes x :: name
  and   p :: "name prm"
  and   T :: "'a::pt_name"

  assumes "x \<sharp> p"

  shows "x \<sharp> (p \<bullet> T) = x \<sharp> T"
proof -
  from assms have "[x] \<sharp>* (p \<bullet> T) = [x] \<sharp>* T"
    by(rule_tac permStarFresh) auto
  thus ?thesis by simp
qed

lemmas freshChainSimps = freshStarSimps freshStarChainSimps permStarFresh swapStarFresh chainFreshFresh freshPerm subsetFresh

lemma freshAlphaPerm:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   Ys   :: "name set"
  and   p    :: "name prm"

  assumes S: "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* xvec"
  and     "Ys \<sharp>* xvec"

  shows "xvec \<sharp>* p"
using assms
apply(induct p)
by auto (simp add: fresh_star_def fresh_def name_list_supp supp_list_nil)+

lemma freshAlphaSwap:
  fixes x  :: name
  and   Xs :: "name set"
  and   Ys :: "name set"
  and   p  :: "name prm"

  assumes S: "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* x"
  and     "Ys \<sharp>* x"

  shows "x \<sharp> p"
proof -
  from assms have "[x] \<sharp>* p"
    apply(rule_tac freshAlphaPerm)
    apply assumption
    by auto
  thus ?thesis by simp
qed

lemma setToListFresh[simp]:
  fixes xvec :: "name list"
  and   C    :: "'a::fs_name"
  and   yvec :: "name list"
  and   Xs   :: "name set"
  and   x    :: name

  shows "xvec \<sharp>* (set yvec) = xvec \<sharp>* yvec"
  and   "Xs \<sharp>* (set yvec) = Xs \<sharp>* yvec"
  and   "x \<sharp> (set yvec) = x \<sharp> yvec"
  and   "set xvec \<sharp>* Xs = xvec \<sharp>* Xs"
by(auto simp add: fresh_star_def name_list_supp fresh_def fs_name1 at_fin_set_supp[OF at_name_inst])

end