theory C
  imports HHLProver.ContinuousInv
    HHLProver.BigStepParallel
    HHLProver.Complementlemma
begin

locale C =
  fixes Stop_point :: real    \<comment> \<open>64000\<close>
  fixes V_limit :: real       \<comment> \<open>100\<close>
  fixes Next_V_limit :: real  \<comment> \<open>40\<close>
  fixes Period :: real        \<comment> \<open>0.125\<close>
  fixes A_minus :: real       \<comment> \<open>1\<close>
  fixes A_plus :: real        \<comment> \<open>1\<close>
  assumes Period[simp]: "Period > 0"
  assumes Stop_point[simp]: "Stop_point > 0"
  assumes V_limit: "V_limit > 0"
  assumes Next_V_limit: "Next_V_limit > 0"
  assumes A_minus: "A_minus > 0"
  assumes A_plus: "A_plus > 0"
begin

definition "Pull_curve_max_d = V_limit * V_limit / (2 * A_minus)"
definition "Pull_curve_coeff = sqrt (2 * A_minus)"

lemma Pull_curve_coeff_ge_zero [simp]:
  "Pull_curve_coeff > 0"
  unfolding Pull_curve_coeff_def using A_minus by auto

lemma Pull_curve_max_d_ge_zero [simp]:
  "Pull_curve_max_d > 0"
  unfolding Pull_curve_max_d_def using V_limit A_minus by auto

text \<open>Variables\<close>

definition A :: char where "A = CHR ''a''"
definition V :: char where "V = CHR ''b''"
definition S :: char where "S = CHR ''c''"
definition T :: char where "T = CHR ''k''"
definition Command_a :: char where "Command_a = CHR ''n''"

lemma train_vars_distinct [simp]: "A \<noteq> V" "A \<noteq> S" "A \<noteq> T"
                                  "V \<noteq> A" "V \<noteq> S" "V \<noteq> T"
                                  "S \<noteq> A" "S \<noteq> V" "S \<noteq> T"
                                  "T \<noteq> A" "T \<noteq> V" "T \<noteq> S"
  unfolding A_def V_def S_def T_def by auto

definition Plant :: proc where
  "Plant =
      Cm (''P2C''[!](\<lambda>s. s V));
      Cm (''P2C''[!](\<lambda>s. s S));
      Cm (''C2P''[?]A);
      Rep (
      Interrupt
      (ODE ((\<lambda>_ _. 0)(S := (\<lambda>s. s V),
                      V := (\<lambda>s. s A))))(\<lambda> s. True)
      [(''P2C''[!](\<lambda>s. s V),
            Cm (''P2C''[!](\<lambda>s. s S));
            Cm (''C2P''[?]A))])"

fun Plant_inv :: "real \<times> real \<times> real \<Rightarrow> (real\<times>real)  list \<Rightarrow> tassn" where
  "Plant_inv (v0, s0, a0) [] = emp\<^sub>t"
| "Plant_inv (v0, s0, a0) ((T_t,a) # as) =
    WaitOut\<^sub>t T_t (\<lambda>t.  ((\<lambda>_. 0)(V := v0+a0*t, S := s0+v0*t+1/2*a0*t*t,
                                            A := a0))) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*T_t, S := s0+v0*T_t+1/2*a0*T_t*T_t, A := a0))) ''P2C'' (s0+v0*T_t+1/2*a0*T_t*T_t)) @\<^sub>t
    (In\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*T_t, S := s0+v0*T_t+1/2*a0*T_t*T_t, A := a0))) ''C2P'' a) @\<^sub>t
    Plant_inv (v0+a0*T_t, s0+v0*T_t+1/2*a0*T_t*T_t, a) (as)"

fun Plant_block :: "real \<times> real \<times> real \<Rightarrow> real \<Rightarrow> (real\<times>real)  list \<Rightarrow> tassn" where
"Plant_block (v0, s0, a00) a0 as =
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''P2C'' v0) @\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''P2C'' s0) @\<^sub>t
    (In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, A := a00))) ''C2P'' a0) @\<^sub>t
    Plant_inv (v0, s0, a0) as"

fun Plant_end_state :: "real \<times> real \<times> real  \<Rightarrow> (real\<times>real)  list\<Rightarrow> state" where
  "Plant_end_state (v0, s0, a0) [] = ((\<lambda>_. 0)(V := v0, S := s0, A := a0))"
| "Plant_end_state (v0, s0, a0) ((T_t,a) # rest) =
   Plant_end_state (v0 + a0 * T_t, s0 + v0 * T_t +
                          1/2 * a0 * T_t * T_t, a) rest"

lemma Plant_end_state_rw:
  "(Plant_end_state (v0, s0, a0) xs) =
   (\<lambda>_. 0)(V := Plant_end_state (v0, s0, a0) xs V,
           S := Plant_end_state (v0, s0, a0) xs S,
           A := Plant_end_state (v0, s0, a0) xs A)"
  apply (induct xs arbitrary: v0 s0 a0) by auto

definition Plant_ode_state :: "state \<Rightarrow> real \<Rightarrow> state" where
  "Plant_ode_state s T_t = (\<lambda>_. 0)(V := s V + s A * T_t,
           S := s S + s V * T_t + s A * T_t * T_t / 2,
           A := s A)"

lemma Plant_end_state_snoc:
  "Plant_end_state (v0, s0, a0) (xs @ [(T_t,a)]) =
   (Plant_ode_state (Plant_end_state (v0, s0, a0) (xs)) T_t) (A := a)"
  apply (induct xs arbitrary: v0 s0 a0 ) unfolding Plant_ode_state_def by auto

lemma Plant_inv_snoc:
  "Plant_inv (v0, s0, a0) (xs @ [(T_t,a)]) =
   Plant_inv (v0, s0, a0) xs @\<^sub>t
   WaitOut\<^sub>t T_t (\<lambda>t.  Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
   Out\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''P2C'' (Plant_end_state (v0, s0, a0) xs S  +
            Plant_end_state (v0, s0, a0) xs V * T_t  +
            (Plant_end_state (v0, s0, a0) xs A) * T_t  * T_t / 2) @\<^sub>t
   In\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''C2P'' a
   "
proof (induct xs arbitrary: v0 s0 a0 )
  case Nil
  then show ?case
    unfolding Plant_ode_state_def apply (auto simp add: fun_upd_def)
    done
next
  case (Cons a xs)
  show ?case
    apply (cases a)
    subgoal for T_t' a'
      by (auto simp add: Cons join_assoc)
    done
qed

lemma Plant_block_snoc:
  "Plant_block (v0, s0, a00) a0 (xs @ [(T_t,a)]) =
   Plant_block (v0, s0, a00) a0  xs @\<^sub>t
   WaitOut\<^sub>t T_t (\<lambda>t.  Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t) ''P2C'' (\<lambda> s. s V) ({''P2C''},{})@\<^sub>t
   Out\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''P2C'' (Plant_end_state (v0, s0, a0) xs S  +
            Plant_end_state (v0, s0, a0) xs V * T_t  +
            (Plant_end_state (v0, s0, a0) xs A) * T_t  * T_t / 2) @\<^sub>t
   In\<^sub>t (State (Plant_ode_state(Plant_end_state (v0, s0, a0) xs) T_t)) ''C2P'' a
   "
  apply auto
  using Plant_inv_snoc[of v0 s0 a0 xs T_t a]
  by (auto simp add: join_assoc)

lemma Plant_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, S := s0, A := a00) \<and> emp\<^sub>t tr}
      Plant
    {\<lambda>s tr. \<exists>a0 xs. s = Plant_end_state (v0, s0, a0) xs \<and>
                 Plant_block (v0, s0, a00) a0 xs tr}"
  unfolding Plant_def
  apply(rule Valid_seq)
   apply (rule Valid_send_sp_st)
  apply(rule Valid_seq)
   apply (rule Valid_send_sp_st)
apply(rule Valid_seq)
   apply (rule Valid_receive_sp_st)
  apply(rule Valid_ex_pre)
  subgoal for a0
    apply(rule Valid_ex_post)
    apply(rule exI[where x= "a0"])
    apply(rule Valid_weaken_pre)
     prefer 2
     apply(rule Valid_rep)
     prefer 2
    subgoal
     apply(auto simp add: entails_def)
      apply(rule exI[where x= "[]"])
      by (auto simp add: join_assoc)
    apply(rule Valid_ex_pre)
    subgoal for xs
      apply(rule Valid_ode_out_unique_solution[where p="\<lambda> t. Plant_ode_state(Plant_end_state (v0, s0, a0) xs) t"])
          apply(auto simp add:Plant_ode_state_def ODEsolInf_def has_vderiv_on_def)
      subgoal
        apply (rule exI[where x="1"])
        apply auto
        apply (rule has_vector_derivative_projI)
        apply (auto simp add: state2vec_def)
         subgoal
       apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal
      apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal premises pre for x i
   proof-
     have eq: "i \<noteq> S \<Longrightarrow>
           i \<noteq> V \<Longrightarrow>
           (\<lambda>t. if i = A then Plant_end_state (v0, s0, a0) xs A
                 else ((\<lambda>_. 0)(V := Plant_end_state (v0, s0, a0) xs V + Plant_end_state (v0, s0, a0) xs A * t,
                               S := Plant_end_state (v0, s0, a0) xs S + Plant_end_state (v0, s0, a0) xs V * t + Plant_end_state (v0, s0, a0) xs A * t * t / 2))
                       i) = (\<lambda>t. if i = A then Plant_end_state (v0, s0, a0) xs A else 0)"
       by auto
     have 1: ?thesis if "i = A"
       using eq that by auto
     have 2: ?thesis if "i \<noteq> A"
       using eq that pre by auto
     show ?thesis using 1 2 by linarith
       qed
       done
     subgoal using Plant_end_state_rw by auto
     subgoal
   proof-
    have bl:"bounded_linear (\<lambda>(v::vec) . \<chi> x. if x = V then (v$A) else if x = S then (v$V) else 0)"
      apply (rule bounded_linearI')
      using vec_lambda_unique by fastforce+
    show ?thesis
      unfolding state2vec_def vec2state_def fun_upd_def
      apply (rule c1_implies_local_lipschitz[where f'="(\<lambda>(t,v). Blinfun(\<lambda>(v::vec) . \<chi> x. if x = V then (v$A) else if x = S then (v$V) else 0))"])
         apply (auto simp add: bounded_linear_Blinfun_apply[OF bl])
      subgoal premises pre for t x
        unfolding has_derivative_def apply (auto simp add: bl)
        apply (rule vec_tendstoI)
        by (auto simp add: state2vec_def)
        done
    qed
    apply(rule Valid_ex_pre)
    subgoal for T_t
      apply(rule Valid_seq)
       apply (rule Valid_send_sp_st)
      apply(rule Valid_strengthen_post)
       prefer 2
       apply(rule Valid_receive_sp_st)
      apply(auto simp add:entails_def)
      subgoal for tr a
        apply(rule exI[where x="xs@[(T_t,a)]"])
        apply auto
        subgoal using Plant_end_state_snoc Plant_end_state_rw
          by(auto simp add: Plant_ode_state_def)
        using Plant_inv_snoc
        by(auto simp add: Plant_ode_state_def join_assoc)
      done
    done
  done
  done

definition fs :: "real \<Rightarrow> real" where
   "fs s =
      (let D = Stop_point - s in
        if D \<ge> Pull_curve_max_d then
          V_limit
        else if D \<ge> 0 then
          Pull_curve_coeff * sqrt(D)
        else 0)"

definition com_a :: "real \<Rightarrow> real \<Rightarrow> real" where
  "com_a s v =
      (let s1' = s + v * Period + A_plus * Period\<^sup>2 / 2 in
       let target_v1 = fs s1' in
         if v + A_plus * Period \<le> target_v1 then
           A_plus
         else let s2' = s + v * Period in
              let target_v2 = fs s2' in
                if v \<le> target_v2 then 0
                else -A_minus)"
lemma control_vars_distinct [simp]: "Command_a \<noteq> V" "Command_a \<noteq> S"
                                  "V \<noteq> Command_a" "V \<noteq> S"
                                  "S \<noteq> Command_a" "S \<noteq> V"
 unfolding Command_a_def V_def S_def by auto

definition Control :: proc where
  "Control =
      Cm (''P2C''[?]V);
      Cm (''P2C''[?]S);
      Command_a ::= (\<lambda>s. com_a (s S) (s V));
      Cm (''C2P''[!](\<lambda>s. s Command_a));
    Rep(
      Wait (\<lambda> s. Period);
      Cm (''P2C''[?]V);
      Cm (''P2C''[?]S);
      Command_a ::= (\<lambda>s. com_a (s S) (s V));
      Cm (''C2P''[!](\<lambda>s. s Command_a)))"

fun Control_inv :: "real \<times> real \<times> real  \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "Control_inv (v0, s0, a0) [] = emp\<^sub>t"
| "Control_inv (v0, s0, a0) ((v, s) # rest) =
    Wait\<^sub>t Period (\<lambda> t. (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0)))) ({},{}) @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))) ''P2C'' v @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s0, Command_a := a0))) ''P2C'' s @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s, Command_a := com_a s v)))  ''C2P'' (com_a s v)  @\<^sub>t
    Control_inv (v,s,com_a s v) rest"

fun Control_block :: "real \<times> real \<times> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "Control_block (v0, s0, a0) v s rest  =
    In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))) ''P2C'' v @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s0, Command_a := a0))) ''P2C'' s @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s, Command_a := com_a s v)))  ''C2P'' (com_a s v)  @\<^sub>t
    Control_inv (v,s,com_a s v) rest"

fun Control_end_state :: "real \<times> real \<times> real  \<Rightarrow> (real \<times> real) list \<Rightarrow> state" where
  "Control_end_state (v0, s0, a0) [] = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0))"
| "Control_end_state (v0, s0, a0) ((v, s) # rest) = Control_end_state (v, s, com_a s v) rest"

definition control_state :: "state \<Rightarrow> real \<Rightarrow> real \<Rightarrow> state" where
  "control_state state v s = state(V := v, S := s, Command_a := com_a s v)"

lemma Control_end_state_snoc:
  "Control_end_state (v0, s0, a0) (xs @ [(v, s)]) =
   control_state (Control_end_state (v0, s0, a0) xs) v s"
  apply (induct xs arbitrary: v0 s0 a0 )
  unfolding control_state_def by auto

lemma Control_end_state_rw:
  "Control_end_state (v0, s0, a0) xs =
   (\<lambda>_ . 0) (V := Control_end_state (v0, s0, a0) xs V,
             S := Control_end_state (v0, s0, a0) xs S,
             Command_a := Control_end_state (v0, s0, a0) xs Command_a)"
  apply (induct xs arbitrary: v0 s0 a0 )
  unfolding control_state_def by auto

lemma Control_state_end_state:
"control_state (Control_end_state (v0, s0, a0) xs) v s = (\<lambda>_ . 0) (V := v,
             S := s,
             Command_a := com_a s v)"
  apply(subst Control_end_state_rw[of v0 s0 a0 xs])
  unfolding control_state_def by auto

lemma Control_inv_snoc:
  "Control_inv (v0, s0, a0) (xs @ [(v, s)]) =
   Control_inv (v0, s0, a0) xs @\<^sub>t
   Wait\<^sub>t Period (\<lambda> t. (State ((Control_end_state (v0, s0, a0) xs)))) ({},{})@\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0) xs))) ''P2C'' v @\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0) xs)(V := v))) ''P2C'' s @\<^sub>t
   Out\<^sub>t (State (control_state (Control_end_state (v0, s0, a0) xs) v s)) ''C2P'' ((control_state (Control_end_state (v0, s0, a0) xs) v s) Command_a)"
  apply (induct xs arbitrary: v0 s0 a0 )
   apply (auto simp add: join_assoc Control_end_state_snoc control_state_def fun_upd_twist)[1]
  apply (auto simp add: join_assoc Control_end_state_snoc fun_upd_twist)
  done

lemma Control_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0)) \<and> emp\<^sub>t tr}
      Control
    {\<lambda>s tr. \<exists>v' s' xs. s = Control_end_state (v', s', com_a s' v') xs
                         \<and> Control_block (v0, s0, a0) v' s' xs tr}"
  unfolding Control_def
  apply(rule Valid_seq)
   apply(rule Valid_receive_sp_st)
  apply(rule Valid_ex_pre)
  subgoal for v'
    apply(rule Valid_seq)
     apply(rule Valid_receive_sp_st)
    apply(rule Valid_ex_pre)
    subgoal for s'
      apply(rule Valid_seq)
       apply(rule Valid_assign_sp_st)
      apply(rule Valid_seq)
       apply(rule Valid_send_sp_st)
      apply(rule Valid_weaken_pre)
       prefer 2
       apply(rule Valid_rep)
       prefer 2
      subgoal
        apply(auto simp add:entails_def)
        subgoal for tr
          apply(rule exI[where x="v'"])
          apply(rule exI[where x="s'"])
          apply(rule exI[where x="[]"])
          by (auto simp add:join_assoc fun_upd_twist)
        done
      apply(rule Valid_ex_pre)
      subgoal for v'
        apply(rule Valid_ex_pre)
        subgoal for s'
          apply(rule Valid_ex_pre)
          subgoal for xs
            apply(rule Valid_seq)
             apply(rule Valid_wait_sp_st)
            apply simp
            apply(rule Valid_seq)
             apply(rule Valid_receive_sp_st)
            apply(rule Valid_ex_pre)
            subgoal for v''
              apply(rule Valid_seq)
               apply(rule Valid_receive_sp_st)
              apply(rule Valid_ex_pre)
              subgoal for s''
                apply(rule Valid_seq)
                 apply(rule Valid_assign_sp_st)
                apply(rule Valid_strengthen_post)
                 prefer 2
                 apply(rule Valid_send_sp_st)
                apply(auto simp add:entails_def)
                apply(rule exI[where x="v'"])
                apply(rule exI[where x="s'"])
                apply(rule exI[where x="xs@[(v'',s'')]"])
                apply auto
                subgoal
                  using Control_end_state_snoc
                  apply(auto simp add:control_state_def)
                  done
                using Control_inv_snoc
                apply(auto simp add:control_state_def join_assoc)
                done
              done
            done
          done
        done
      done
    done
  done

lemma fs_at_least_zero:
  "fs s \<ge> 0"
  unfolding fs_def Let_def apply auto
  using V_limit apply auto
  using  Pull_curve_coeff_ge_zero
  by (simp add: dual_order.strict_implies_order)

lemma fs_at_most_limit:
  "fs s \<le> V_limit"
  unfolding fs_def Let_def
  apply auto
  subgoal premises pre
  proof-
    have "Stop_point - s < V_limit * V_limit / (2 * A_minus)"
        using pre unfolding Pull_curve_max_d_def Pull_curve_coeff_def by auto
      then have 31: "(Stop_point - s) * (2 * A_minus) < V_limit * V_limit"
        using A_minus
        by (metis lattice_ab_group_add_class.zero_less_double_add_iff_zero_less_single_add mult_2 pos_less_divide_eq)
      have 32: "sqrt (2 * A_minus) * sqrt (Stop_point - s) = sqrt ((Stop_point - s) * (2 * A_minus))"
        using A_minus pre by (simp add: real_sqrt_mult)
      have 33: "V_limit = sqrt (V_limit * V_limit)"
        using V_limit by auto
      show ?thesis
        unfolding Pull_curve_max_d_def Pull_curve_coeff_def 32
        apply (subst 33) using 31
        using real_sqrt_less_iff
        using less_eq_real_def by blast
    qed
    subgoal using V_limit by auto
    done

lemma fs_prop1:
  assumes "v \<le> fs(s)"
    and "v \<ge> 0"
    and "s \<le> Stop_point"
  shows "v^2 \<le> 2 * A_minus * (Stop_point - s)"
proof-
  have 1: "v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s \<ge> Pull_curve_max_d"
  proof-
    have 11: "v\<le>V_limit"
      using assms(1) that unfolding fs_def Let_def by auto
    then have 12: "v^2\<le>V_limit^2"
      using assms(2) V_limit by simp
    have 13:" V_limit^2 \<le>2 * A_minus * (Stop_point - s)"
      using that A_minus unfolding Pull_curve_max_d_def
      by (auto simp add: power2_eq_square field_simps)
    then show ?thesis using 12 by auto
  qed
  have 2:"v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s < Pull_curve_max_d"
  proof-
    have 21:"v \<le> Pull_curve_coeff * sqrt(Stop_point - s)"
      using assms that unfolding fs_def by auto
    then show ?thesis using assms A_minus unfolding Pull_curve_coeff_def
      by (metis power2_eq_square real_sqrt_le_iff real_sqrt_mult real_sqrt_pow2)
  qed
  show ?thesis using 1 2 assms
    by linarith
qed

fun loop_once :: "real \<times> real \<Rightarrow> real \<times> real" where
  "loop_once (s, v) =
    (let a = com_a s v in
     let v' = v + a * Period in
     let s' = s + v * Period + a * Period * Period / 2 in
      (s', v'))"

declare loop_once.simps[simp del]

lemma loop_once_invariant:
  assumes "v \<le> fs s \<and> s \<le> Stop_point"
    and "(s', v') = loop_once (s, v)"
  shows "v' \<le> fs s' \<and> s' \<le> Stop_point"
proof -
  have case1:"v' \<le> fs s' \<and> s' \<le> Stop_point" if cond1:"v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
  proof-
    have 1:"com_a s v = A_plus"
      using that unfolding com_a_def by auto
    have 2:"(s', v') = (s + v * Period + A_plus * Period\<^sup>2 / 2,v + A_plus * Period )"
      using assms 1  that loop_once.simps by (auto simp add: power2_eq_square)
    have 3:"v' \<le> fs s'"
      using that 2
      unfolding fs_def Let_def by auto
    have 4:"s' \<le> Stop_point"
    proof (cases "v' > 0")
      case True
      then show ?thesis
        using 3 2 that apply(simp add: fs_def Let_def) apply auto
        by (smt Pull_curve_max_d_ge_zero)
    next
      case False
      then show ?thesis
      proof-
        have "v + A_plus * Period \<le> 0"
          using False 2 by auto
        then have "(v + A_plus * Period)*Period \<le> 0"
          by (meson Period eucl_less_le_not_le mult_le_0_iff)
        then have "v * Period + A_plus * Period\<^sup>2 \<le>0"
          by(auto simp add:power2_eq_square algebra_simps)
        then have "v * Period + A_plus * Period\<^sup>2 - A_plus * Period*Period/2 \<le>0"
          apply(subgoal_tac "A_plus * Period*Period/2 > 0")
           prefer 2 using A_plus apply simp
          by linarith
        then have "v * Period + A_plus * Period\<^sup>2/2 \<le>0"
          by(auto simp add: power2_eq_square)
        then have "s + v * Period + A_plus * Period\<^sup>2/2 \<le> Stop_point"
          using assms by auto
        then show ?thesis using 2 apply auto done
      qed
    qed
     show ?thesis using 3 4 by auto
  qed
  have case2:"v' \<le> fs s' \<and>  s' \<le> Stop_point" if cond2:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "v \<le> fs (s + v * Period)"
  proof-
    have 1: "com_a s v = 0" using that unfolding com_a_def by auto
    have 2: "(s',v') = (s + v * Period, v)" using assms 1 loop_once.simps by auto
    have 3:"v' \<le> fs s'"
      using 2 that
      unfolding fs_def Let_def by auto
    have 4:"s' \<le> Stop_point"
    proof-
      have "v \<le> 0" if "s' > Stop_point"
        using 2 3 unfolding fs_def Let_def
        using Pull_curve_max_d_ge_zero assms(1) that by auto
      then have"s\<ge>s'" if "s' > Stop_point" using 2 that
        by (smt Period old.prod.inject zero_less_mult_pos2)
      then show ?thesis using assms
        using leI 2   by auto
    qed
    then show ?thesis using 3 4  by auto
  qed
  have case3:"v' \<le> fs s'  \<and> s' \<le> Stop_point" if cond3:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "\<not> v \<le> fs (s + v * Period)"
  proof-
    have 1: "com_a s v = -A_minus" using that unfolding com_a_def by auto
    have 2:"(s',v') = (s + v * Period - A_minus * Period\<^sup>2 / 2, v - A_minus  * Period)"
        using assms 1  cond3 loop_once.simps by (auto simp add: power2_eq_square)
    have 31:"s' \<le> Stop_point" if "v\<ge>0"
        using 2 apply auto
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
              using fs_prop1 assms that by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have " 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)) \<ge> 0"
            by (smt zero_le_power2)
          then have "(Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)) \<ge> 0"
            by (metis A_minus less_eq_real_def linordered_ab_group_add_class.double_add_le_zero_iff_single_add_le_zero mult_less_cancel_right not_one_le_zero not_real_square_gt_zero one_add_one zero_le_mult_iff zero_less_mult_iff)
          then show ?thesis by auto
            qed
            done
          have 32:"s' \<le> Stop_point" if "v<0"
            using 2 apply auto
            apply (subgoal_tac"s \<le> Stop_point")
             prefer 2 using assms apply auto
            apply (subgoal_tac"v * Period \<le> 0")
            prefer 2 using that Period
             apply (smt cond3(2) fs_at_least_zero)
            apply (subgoal_tac" A_minus * Period\<^sup>2 / 2 \<ge> 0")
             prefer 2
            subgoal
              using A_minus by(auto simp add:power2_eq_square)
            by linarith
       have 41:"v' \<le> fs s'" if "v\<ge>0"
        using 2
        unfolding fs_def Let_def apply auto
        subgoal using assms(1) fs_at_most_limit A_minus Period
          by (smt mult_diff_mult real_mult_less_iff1)
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
            using fs_prop1 assms that by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have a:"sqrt((v - A_minus * Period)^2) \<le> sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            using real_sqrt_le_iff by blast
          have b:"(v - A_minus * Period) <= sqrt((v - A_minus * Period)^2)"
            by auto
          have c:"sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))) = sqrt(2 * A_minus) * sqrt((Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            by (simp add: real_sqrt_mult)
          show ?thesis using a b c unfolding Pull_curve_coeff_def by auto
        qed
        subgoal using assms fs_at_most_limit A_minus Period
          using Pull_curve_max_d_ge_zero by linarith
        subgoal using 31 that by auto
        done
      have 42:"v' \<le> fs s'" if "v<0"
        using 2
        unfolding fs_def Let_def apply auto
        subgoal using assms(1) fs_at_most_limit A_minus Period
          by (smt mult_diff_mult real_mult_less_iff1)
        subgoal
          apply(subgoal_tac "s + v * Period - A_minus * Period\<^sup>2 / 2  \<le> s")
           prefer 2 subgoal
           apply (subgoal_tac"s \<le> Stop_point")
             prefer 2 using assms apply auto
            apply (subgoal_tac"v * Period \<le> 0")
            prefer 2 using that Period
             apply (smt cond3(2) fs_at_least_zero)
            apply (subgoal_tac" A_minus * Period\<^sup>2 / 2 \<ge> 0")
             prefer 2
            subgoal
              using A_minus by(auto simp add:power2_eq_square)
            apply linarith
            done
            apply(subgoal_tac" \<not> Pull_curve_max_d \<le> Stop_point - s")
             prefer 2
             apply simp
            apply(subgoal_tac"v \<le> Pull_curve_coeff * sqrt (Stop_point - s)")
            prefer 2
            subgoal using assms unfolding fs_def Let_def by auto
            apply(subgoal_tac"v - A_minus * Period \<le> v")
            prefer 2 subgoal using A_minus
              by (smt cond3(2) fs_at_least_zero that)
            apply(subgoal_tac"Pull_curve_coeff * sqrt (Stop_point - s)\<le>Pull_curve_coeff * sqrt (Stop_point - (s + v * Period - A_minus * Period\<^sup>2 / 2))")
             apply linarith
            by simp
          subgoal using assms fs_at_most_limit A_minus Period
            using Pull_curve_max_d_ge_zero by linarith
          subgoal using that A_minus
            using "32" by auto
          done
       show ?thesis using 31 32 41 42
         using leI by blast
    qed
  show ?thesis
    using case1 case2 case3
    by linarith
qed

fun loop_invariant :: "real \<times> real \<Rightarrow> bool" where
  "loop_invariant (s, v) \<longleftrightarrow> v \<le> fs s \<and> s \<le> Stop_point"

lemma loop_once_invariant':
  assumes "loop_invariant (s,v)"
    and "(s', v') = loop_once (s, v)"
  shows "loop_invariant (s',v')"
  using loop_once_invariant assms
  using loop_invariant.simps by blast

fun tot_inv :: "real \<times> real \<Rightarrow> nat \<Rightarrow> tassn" where
  "tot_inv (s0, v0) 0 = emp\<^sub>t"
| "tot_inv (s0, v0) (Suc n) =
   (\<up>(loop_invariant (s0, v0)) \<and>\<^sub>t Wait\<^sub>t (Period) (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0 + com_a s0 v0 * t, S := s0 + v0 * t + com_a s0 v0 * t * t / 2, A := com_a s0 v0)))
                    (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0)) )) ({''P2C''}, {})) @\<^sub>t
   IO\<^sub>t ''P2C'' (snd (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''P2C'' (fst (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''C2P'' (com_a (fst (loop_once (s0, v0))) (snd (loop_once (s0, v0)))) @\<^sub>t
   tot_inv (loop_once (s0, v0) ) n"

fun tot_block :: "real \<times> real \<Rightarrow> nat \<Rightarrow> tassn" where
"tot_block (s0, v0) n =
   IO\<^sub>t ''P2C'' v0 @\<^sub>t
   IO\<^sub>t ''P2C'' s0 @\<^sub>t
   IO\<^sub>t ''C2P'' (com_a s0 v0) @\<^sub>t tot_inv (s0, v0) n "

lemma combine0:
  "loop_invariant (s0, v0) \<Longrightarrow>
   combine_assn {''P2C'', ''C2P''}
     (Plant_inv (v0, s0, com_a s0 v0) as) (Control_inv (v0, s0, com_a s0 v0) vs)
      \<Longrightarrow>\<^sub>t  tot_inv (s0,v0) (length as)"
proof (induct as arbitrary: vs s0 v0)
case Nil
  then show ?case
  proof(cases vs)
    case Nil
    then show ?thesis
      by auto
  next
    case (Cons vsp vsrest)
    then show ?thesis
      apply auto
      subgoal
    proof (cases vsp)
      case (Pair v1 s1)
      then show ?thesis
        apply auto
        apply (rule entails_tassn_trans)
       apply (rule combine_assn_emp_wait)
        apply simp by (rule false_assn_entails)
    qed
    done
  qed
next
  case (Cons asp asrest)
  note Cons1 = Cons
  then show ?case
  proof (cases asp)
    case (Pair T1 a1)
    note Pair1 = Pair
    then show ?thesis
    proof (cases vs)
      case Nil
      then show ?thesis
        apply(auto simp add:Pair)
        apply (rule entails_tassn_trans)
       apply(rule combine_assn_waitout_emp)
         apply simp by (rule false_assn_entails)
next
  case (Cons vsp vsrest)
  then show ?thesis
    subgoal
proof (cases vsp)
  case (Pair v1' s1')
  then show ?thesis
    apply(auto simp add: Cons Pair1)
    apply (rule entails_tassn_trans)
      apply (rule combine_assn_waitout_wait)
       apply auto
    apply (rule entails_tassn_conj)
    subgoal
      using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
      done
    apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_waitout_in)
      apply (auto simp add:loop_once.simps Let_def)
apply (rule entails_tassn_cancel_left)
    apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
    apply (rule entails_tassn_cancel_left)
 apply (rule entails_tassn_trans)
     apply (rule combine_assn_in_out)
     apply auto
    apply (rule entails_tassn_cancel_left)
    using Cons1(1)[of "s0 + v0 * Period + com_a s0 v0 * Period * Period / 2" "v0 + com_a s0 v0 * Period" "vsrest"] Cons1(2)
    using loop_once_invariant'[of s0 v0 "s0 + v0 * Period + com_a s0 v0 * Period * Period / 2" "v0 + com_a s0 v0 * Period"]
    by(auto simp add:loop_once.simps Let_def)
qed
  done
qed
  qed
qed

lemma combine:
  "loop_invariant (s0, v0) \<Longrightarrow>
   combine_assn {''P2C'', ''C2P''}
     (Plant_block (v0, s0, a00) a0 as) (Control_block (v00', s00', a00') v0' s0' vs)
      \<Longrightarrow>\<^sub>t  tot_block (s0,v0) (length as)"
  apply auto
apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
  apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_out_in)
    apply auto
  apply (rule entails_tassn_cancel_left)
apply (rule entails_tassn_trans)
     apply (rule combine_assn_in_out)
    apply auto
  apply (rule entails_tassn_cancel_left)
  apply(rule combine0)
  by auto

definition System :: pproc where
  "System = Parallel (Single Plant)
                     {''P2C'', ''C2P''}
                     (Single Control)"

lemma System_Prop:
  assumes "loop_invariant (s0, v0)"
  shows "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(V := v0, S := s0, A := a00)))
               (\<lambda>s. s = ((\<lambda>_. 0)(V := v00', S := s00', Command_a := a00')))}
      System
    {\<exists>\<^sub>g n. trace_gassn (tot_block (s0,v0) n)}"
unfolding System_def
  apply (rule ParValid_conseq')
    apply (rule ParValid_Parallel')
  apply (rule Plant_prop)
  apply (rule Control_prop)
  apply (auto simp add: sing_gassn_split sing_gassn_ex)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_left)
  subgoal for a0 as
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for v' s' vs
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length as"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
     apply (rule entails_tassn_trans)
      prefer 2 apply(rule combine[OF assms])
     apply (rule combine_assn_mono)
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done
  done

end
end


(*  Title:      Jinja/Common/TypeRel.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Relations between Jinja Types\<close>

theory TypeRel imports
  "HOL-Library.Transitive_Closure_Table"
  Decl
begin

subsection\<open>The subclass relations\<close>

inductive_set
  subcls1 :: "'m prog \<Rightarrow> (cname \<times> cname) set"
  and subcls1' :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71,71,71] 70)
  for P :: "'m prog"
where
  "P \<turnstile> C  \<prec>\<^sup>1 D \<equiv> (C,D) \<in> subcls1 P"
| subcls1I: "\<lbrakk>class P C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation
  subcls  :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70)
  where "P \<turnstile> C  \<preceq>\<^sup>*  D \<equiv> (C,D) \<in> (subcls1 P)\<^sup>*"

lemma subcls1D: "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class P C = Some (D,fs,ms))"
(*<*)by(erule subcls1.induct)(fastforce simp add:is_class_def)(*>*)

lemma [iff]: "(P \<turnstile> Object \<preceq>\<^sup>* C) = (C = Object)"
(*<*)
apply(rule iffI)
 apply(erule converse_rtranclE)
  apply simp_all
done
(*>*)

lemma subcls1_def2:
  "subcls1 P =
     (SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D})"
(*<*)
  by (fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
(*>*)

lemma finite_subcls1: "finite (subcls1 P)"
(*<*)
apply (simp add: subcls1_def2)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class P C))}" in finite_subset)
apply  auto
done
(*>*)
(*
lemma subcls_is_class: "(C,D) \<in> (subcls1 P)\<^sup>+ \<Longrightarrow> is_class P C"
apply (unfold is_class_def)
apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done

lemma subcls_is_class: "P \<turnstile> C \<preceq>\<^sup>* D \<Longrightarrow> is_class P D \<longrightarrow> is_class P C"
apply (unfold is_class_def)
apply (erule rtrancl_induct)
apply  (drule_tac [2] subcls1D)
apply  auto
done
*)

subsection\<open>The subtype relations\<close>

inductive
  widen   :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ \<le> _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P \<turnstile> T \<le> T"
| widen_subcls: "P \<turnstile> C \<preceq>\<^sup>* D  \<Longrightarrow>  P \<turnstile> Class C \<le> Class D"
| widen_null[iff]: "P \<turnstile> NT \<le> Class C"

abbreviation
  widens :: "'m prog \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> bool"
    ("_ \<turnstile> _ [\<le>] _" [71,71,71] 70) where
  "widens P Ts Ts' \<equiv> list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P \<turnstile> T \<le> Void) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Void \<le> T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Boolean \<le> T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Integer \<le> T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P \<turnstile> Class C \<le> T  \<Longrightarrow>  \<exists>D. T = Class D"
(*<*)
apply (ind_cases "P \<turnstile> Class C \<le> T")
apply auto
done
(*>*)

lemma [iff]: "(P \<turnstile> T \<le> NT) = (T = NT)"
(*<*)
apply(cases T)
apply(auto dest:Class_widen)
done
(*>*)

lemma Class_widen_Class [iff]: "(P \<turnstile> Class C \<le> Class D) = (P \<turnstile> C \<preceq>\<^sup>* D)"
(*<*)
apply (rule iffI)
apply (ind_cases "P \<turnstile> Class C \<le> Class D")
apply (auto elim: widen_subcls)
done
(*>*)

lemma widen_Class: "(P \<turnstile> T \<le> Class C) = (T = NT \<or> (\<exists>D. T = Class D \<and> P \<turnstile> D \<preceq>\<^sup>* C))"
(*<*)by(induct T, auto)(*>*)

lemma widen_trans[trans]: "\<lbrakk>P \<turnstile> S \<le> U; P \<turnstile> U \<le> T\<rbrakk> \<Longrightarrow> P \<turnstile> S \<le> T"
(*<*)
proof -
  assume "P\<turnstile>S \<le> U" thus "\<And>T. P \<turnstile> U \<le> T \<Longrightarrow> P \<turnstile> S \<le> T"
  proof induct
    case (widen_refl T T') thus "P \<turnstile> T \<le> T'" .
  next
    case (widen_subcls C D T)
    then obtain E where "T = Class E" by (blast dest: Class_widen)
    with widen_subcls show "P \<turnstile> Class C \<le> T" by (auto elim: rtrancl_trans)
  next
    case (widen_null C RT)
    then obtain D where "RT = Class D" by (blast dest: Class_widen)
    thus "P \<turnstile> NT \<le> RT" by auto
  qed
qed
(*>*)

lemma widens_trans [trans]: "\<lbrakk>P \<turnstile> Ss [\<le>] Ts; P \<turnstile> Ts [\<le>] Us\<rbrakk> \<Longrightarrow> P \<turnstile> Ss [\<le>] Us"
(*<*)by (rule list_all2_trans, rule widen_trans)(*>*)

(*<*)
lemmas widens_refl [iff] = list_all2_refl [of "widen P", OF widen_refl] for P
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
(*>*)

subsection\<open>Method lookup\<close>

inductive
  Methods :: "['m prog, cname, mname \<rightharpoonup> (ty list \<times> ty \<times> 'm) \<times> cname] \<Rightarrow> bool"
                    ("_ \<turnstile> _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
  sees_methods_Object:
 "\<lbrakk> class P Object = Some(D,fs,ms); Mm = map_option (\<lambda>m. (m,Object)) \<circ> map_of ms \<rbrakk>
  \<Longrightarrow> P \<turnstile> Object sees_methods Mm"
| sees_methods_rec:
 "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D sees_methods Mm;
    Mm' = Mm ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms) \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees_methods Mm'"

lemma sees_methods_fun:
assumes 1: "P \<turnstile> C sees_methods Mm"
shows "\<And>Mm'. P \<turnstile> C sees_methods Mm' \<Longrightarrow> Mm' = Mm"
 (*<*)
using 1
proof induct
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and Dmethods: "P \<turnstile> D sees_methods Dres"
   and IH: "\<And>Dres'. P \<turnstile> D sees_methods Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = Dres ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
   and Cmethods': "P \<turnstile> C sees_methods Cres'" by fact+
  from Cmethods' notObj "class" obtain Dres'
    where Dmethods': "P \<turnstile> D sees_methods Dres'"
     and Cres': "Cres' = Dres' ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
    by(auto elim: Methods.cases)
  from Cres Cres' IH[OF Dmethods'] show "Cres' = Cres" by simp
next
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
qed
(*>*)

lemma visible_methods_exist:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow> Mm M = Some(m,D) \<Longrightarrow>
   (\<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some m)"
 (*<*)by(induct rule:Methods.induct) auto(*>*)

lemma sees_methods_decl_above:
assumes Csees: "P \<turnstile> C sees_methods Mm"
shows "Mm M = Some(m,D) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)
using Csees
proof induct
  case sees_methods_Object thus ?case by auto
next
  case sees_methods_rec thus ?case
    by(fastforce simp:map_option_case split:option.splits
                elim:converse_rtrancl_into_rtrancl[OF subcls1I])
qed
(*>*)

lemma sees_methods_idemp:
assumes Cmethods: "P \<turnstile> C sees_methods Mm"
shows "\<And>m D. Mm M = Some(m,D) \<Longrightarrow>
              \<exists>Mm'. (P \<turnstile> D sees_methods Mm') \<and> Mm' M = Some(m,D)"
(*<*)
using Cmethods
proof induct
  case sees_methods_Object thus ?case
    by(fastforce dest: Methods.sees_methods_Object)
next
  case sees_methods_rec thus ?case
    by(fastforce split:option.splits dest: Methods.sees_methods_rec)
qed
(*>*)

(*FIXME something wrong with induct: need to attache [consumes 1]
directly to proof of thm, declare does not work. *)

lemma sees_methods_decl_mono:
assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
shows "P \<turnstile> C sees_methods Mm \<Longrightarrow>
       \<exists>Mm' Mm\<^sub>2. P \<turnstile> C' sees_methods Mm' \<and> Mm' = Mm ++ Mm\<^sub>2 \<and>
                 (\<forall>M m D. Mm\<^sub>2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
(*<*)
      (is "_ \<Longrightarrow> \<exists>Mm' Mm2. ?Q C' C Mm' Mm2")
using sub
proof (induct rule:converse_rtrancl_induct)
  assume "P \<turnstile> C sees_methods Mm"
  hence "?Q C C Mm Map.empty" by simp
  thus "\<exists>Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  fix C'' C'
  assume sub1: "P \<turnstile> C'' \<prec>\<^sup>1 C'" and sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
  and IH: "P \<turnstile> C sees_methods Mm \<Longrightarrow>
           \<exists>Mm' Mm2. P \<turnstile> C' sees_methods Mm' \<and>
                Mm' = Mm ++ Mm2 \<and> (\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
  and Csees: "P \<turnstile> C sees_methods Mm"
  from IH[OF Csees] obtain Mm' Mm2 where C'sees: "P \<turnstile> C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC:"\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' \<noteq> Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (\<lambda>m. (m,C'')) \<circ> map_of ms"
  have "P \<turnstile> C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtrancl_into_rtrancl[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "\<exists>Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
(*>*)

definition Method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> cname \<Rightarrow> bool"
            ("_ \<turnstile> _ sees _: _\<rightarrow>_ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D  \<equiv>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm M = Some((Ts,T,m),D)"

definition has_method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> bool" ("_ \<turnstile> _ has _" [51,0,51] 50)
where
  "P \<turnstile> C has M \<equiv> \<exists>Ts T m D. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D"

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C sees M:TS\<rightarrow>T = m in D; P \<turnstile> C sees M:TS'\<rightarrow>T' = m' in D' \<rbrakk>
   \<Longrightarrow> TS' = TS \<and> T' = T \<and> m' = m \<and> D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow>
  \<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)

lemma sees_method_idemp:
  "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D \<Longrightarrow> P \<turnstile> D sees M:Ts\<rightarrow>T=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; P \<turnstile> C sees M:Ts\<rightarrow>T = m in D;
     P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<rbrakk> \<Longrightarrow> P \<turnstile> D' \<preceq>\<^sup>* D"
 (*<*)
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtrancl_trans)
done
(*>*)

lemma sees_method_is_class:
  "\<lbrakk> P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<rbrakk> \<Longrightarrow> is_class P C"
(*<*)by (auto simp add: is_class_def Method_def elim: Methods.induct)(*>*)

subsection\<open>Field lookup\<close>

inductive
  Fields :: "['m prog, cname, ((vname \<times> cname) \<times> ty) list] \<Rightarrow> bool"
                  ("_ \<turnstile> _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D has_fields FDTs;
     FDTs' = map (\<lambda>(F,T). ((F,C),T)) fs @ FDTs \<rbrakk>
   \<Longrightarrow> P \<turnstile> C has_fields FDTs'"
| has_fields_Object:
  "\<lbrakk> class P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
   \<Longrightarrow> P \<turnstile> Object has_fields FDTs"

lemma has_fields_fun:
assumes 1: "P \<turnstile> C has_fields FDTs"
shows "\<And>FDTs'. P \<turnstile> C has_fields FDTs' \<Longrightarrow> FDTs' = FDTs"
 (*<*)
using 1
proof induct
  case (has_fields_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and DFields: "P \<turnstile> D has_fields Dres"
   and IH: "\<And>Dres'. P \<turnstile> D has_fields Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres"
   and CFields': "P \<turnstile> C has_fields Cres'" by fact+
  from CFields' notObj "class" obtain Dres'
    where DFields': "P \<turnstile> D has_fields Dres'"
     and Cres': "Cres' = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres'"
    by(auto elim: Fields.cases)
  from Cres Cres' IH[OF DFields'] show "Cres' = Cres" by simp
next
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
qed
(*>*)

lemma all_fields_in_has_fields:
assumes sub: "P \<turnstile> C has_fields FDTs"
shows "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; class P D = Some(D',fs,ms); (F,T) \<in> set fs \<rbrakk>
       \<Longrightarrow> ((F,D),T) \<in> set FDTs"
(*<*)
using sub apply(induct)
 apply(simp add:image_def)
 apply(erule converse_rtranclE)
  apply(force)
 apply(drule subcls1D)
 apply fastforce
apply(force simp:image_def)
done
(*>*)

lemma has_fields_decl_above:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
using fields apply(induct)
 prefer 2 apply fastforce
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
apply simp
apply(blast dest:subcls1I converse_rtrancl_into_rtrancl)
done
(*>*)

lemma subcls_notin_has_fields:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> (D,C) \<notin> (subcls1 P)\<^sup>+"
(*<*)
using fields apply(induct)
 prefer 2 apply(fastforce dest: tranclD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:all_fields_in_has_fields)
apply simp
apply(blast dest:subcls1I trancl_into_trancl)
done
(*>*)

lemma has_fields_mono_lem:
assumes sub: "P \<turnstile> D \<preceq>\<^sup>* C"
shows "P \<turnstile> C has_fields FDTs
         \<Longrightarrow> \<exists>pre. P \<turnstile> D has_fields pre@FDTs \<and> dom(map_of pre) \<inter> dom(map_of FDTs) = {}"
(*<*)
using sub apply(induct rule:converse_rtrancl_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(D',C) : (subcls1 P)^+")
 prefer 2 apply(erule (1) rtrancl_into_trancl2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (\<lambda>(F,T). ((F,D'),T)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done
(*>*)

(* FIXME why is Field not displayed correctly? TypeRel qualifier seems to confuse printer*)
definition has_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                   ("_ \<turnstile> _ has _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C has F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and> map_of FDTs (F,D) = Some T"

lemma has_field_mono:
  "\<lbrakk> P \<turnstile> C has F:T in D; P \<turnstile> C' \<preceq>\<^sup>* C \<rbrakk> \<Longrightarrow> P \<turnstile> C' has F:T in D"
(*<*)
apply(clarsimp simp:has_field_def)
apply(drule (1) has_fields_mono_lem)
apply(fastforce simp: map_add_def split:option.splits)
done
(*>*)

definition sees_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                  ("_ \<turnstile> _ sees _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C sees F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and>
            map_of (map (\<lambda>((F,D),T). (F,(D,T))) FDTs) F = Some(D,T)"

lemma map_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow> map_of t (k, k') = Some x"
(*<*)by (induct t) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma has_visible_field:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C has F:T in D"
(*<*)by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)(*>*)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C sees F:T in D; P \<turnstile> C sees F:T' in D'\<rbrakk> \<Longrightarrow> T' = T \<and> D' = D"
(*<*)by(fastforce simp:sees_field_def dest:has_fields_fun)(*>*)

lemma sees_field_decl_above:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
apply(auto simp:sees_field_def)
apply(blast  intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
done
(*>*)

(* FIXME ugly *)
lemma sees_field_idemp:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> D sees F:T in D"
(*<*)
  apply (unfold sees_field_def)
  apply clarsimp
  apply (rule_tac P = "map_of xs F = y" for xs y in mp)
   prefer 2
   apply assumption
  apply (thin_tac "map_of xs F = y" for xs y)
  apply (erule Fields.induct)
   apply clarsimp
   apply (frule map_of_SomeD)
   apply clarsimp
   apply (fastforce intro: has_fields_rec)
  apply clarsimp
  apply (frule map_of_SomeD)
  apply clarsimp
  apply (fastforce intro: has_fields_Object)
  done
(*>*)

subsection "Functional lookup"

definition "method" :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> cname \<times> ty list \<times> ty \<times> 'm"
where
  "method P C M  \<equiv>  THE (D,Ts,T,m). P \<turnstile> C sees M:Ts \<rightarrow> T = m in D"

definition field  :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> cname \<times> ty"
where
  "field P C F  \<equiv>  THE (D,T). P \<turnstile> C sees F:T in D"

definition fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> ty) list"
where
  "fields P C  \<equiv>  THE FDTs. P \<turnstile> C has_fields FDTs"

lemma fields_def2 [simp]: "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
(*<*)by (unfold fields_def) (auto dest: has_fields_fun)(*>*)

lemma field_def2 [simp]: "P \<turnstile> C sees F:T in D \<Longrightarrow> field P C F = (D,T)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D \<Longrightarrow> method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

subsection "Code generator setup"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1p
.
declare subcls1_def [code_pred_def]

code_pred
  (modes: i \<Rightarrow> i \<times> o \<Rightarrow> bool, i \<Rightarrow> i \<times> i \<Rightarrow> bool)
  [inductify]
  subcls1
.
definition subcls' where "subcls' G = (subcls1p G)^**"
code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 G)^* = {(C, D). subcls' G C D}"
  by (simp add: subcls'_def subcls1_def rtrancl_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  widen
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields
.

lemma has_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of FDTs (F, D) = \<lfloor>T\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C has F:T in D"
by(auto simp add: has_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  has_field
by(auto simp add: has_field_def)

lemma sees_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of (map (\<lambda>((F, D), T). (F, D, T)) FDTs) F = \<lfloor>(D, T)\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees F:T in D"
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  sees_field
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  Method
by(auto simp add: Method_def)

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (\<lambda>(Ts, T, m, D). P \<turnstile> C sees M:Ts\<rightarrow>T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M =
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (\<lambda>(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (\<lambda>FDTs. P \<turnstile> C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

lemma eval_sees_field_i_i_i_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o P C F) = (\<lambda>(T, D). P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_oI elim: sees_field_i_i_i_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_i P C F D) = (\<lambda>T. P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o P C F) (\<lambda>(T, D). Predicate.single (D, T)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

(*<*)
end
(*>*)


(*  Title:      HOL/Library/Old_Recdef.thy
    Author:     Konrad Slind and Markus Wenzel, TU Muenchen
*)

section {* TFL: recursive function definitions *}

theory Old_Recdef
imports Main
keywords
  "recdef" "defer_recdef" :: thy_decl and
  "recdef_tc" :: thy_goal and
  "permissive" "congs" "hints"
begin

subsection {* Lemmas for TFL *}

lemma tfl_wf_induct: "ALL R. wf R -->
       (ALL P. (ALL x. (ALL y. (y,x):R --> P y) --> P x) --> (ALL x. P x))"
apply clarify
apply (rule_tac r = R and P = P and a = x in wf_induct, assumption, blast)
done

lemma tfl_cut_def: "cut f r x \<equiv> (\<lambda>y. if (y,x) \<in> r then f y else undefined)"
  unfolding cut_def .

lemma tfl_cut_apply: "ALL f R. (x,a):R --> (cut f R a)(x) = f(x)"
apply clarify
apply (rule cut_apply, assumption)
done

lemma tfl_wfrec:
     "ALL M R f. (f=wfrec R M) --> wf R --> (ALL x. f x = M (cut f R x) x)"
apply clarify
apply (erule wfrec)
done

lemma tfl_eq_True: "(x = True) --> x"
  by blast

lemma tfl_rev_eq_mp: "(x = y) --> y --> x"
  by blast

lemma tfl_simp_thm: "(x --> y) --> (x = x') --> (x' --> y)"
  by blast

lemma tfl_P_imp_P_iff_True: "P ==> P = True"
  by blast

lemma tfl_imp_trans: "(A --> B) ==> (B --> C) ==> (A --> C)"
  by blast

lemma tfl_disj_assoc: "(a \<or> b) \<or> c == a \<or> (b \<or> c)"
  by simp

lemma tfl_disjE: "P \<or> Q ==> P --> R ==> Q --> R ==> R"
  by blast

lemma tfl_exE: "\<exists>x. P x ==> \<forall>x. P x --> Q ==> Q"
  by blast

ML_file "~~/src/HOL/Tools/TFL/casesplit.ML"
ML_file "~~/src/HOL/Tools/TFL/utils.ML"
ML_file "~~/src/HOL/Tools/TFL/usyntax.ML"
ML_file "~~/src/HOL/Tools/TFL/dcterm.ML"
ML_file "~~/src/HOL/Tools/TFL/thms.ML"
ML_file "~~/src/HOL/Tools/TFL/rules.ML"
ML_file "~~/src/HOL/Tools/TFL/thry.ML"
ML_file "~~/src/HOL/Tools/TFL/tfl.ML"
ML_file "~~/src/HOL/Tools/TFL/post.ML"
ML_file "~~/src/HOL/Tools/recdef.ML"

subsection {* Rule setup *}

lemmas [recdef_simp] =
  inv_image_def
  measure_def
  lex_prod_def
  same_fst_def
  less_Suc_eq [THEN iffD2]

lemmas [recdef_cong] =
  if_cong let_cong image_cong INF_cong SUP_cong bex_cong ball_cong imp_cong
  map_cong filter_cong takeWhile_cong dropWhile_cong foldl_cong foldr_cong

lemmas [recdef_wf] =
  wf_trancl
  wf_less_than
  wf_lex_prod
  wf_inv_image
  wf_measure
  wf_measures
  wf_pred_nat
  wf_same_fst
  wf_empty

end


(* Title: Adaptation of example from HOL/Hoare/Separation
   Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "Example from HOL/Hoare/Separation"

theory Simple_Separation_Example
  imports "~~/src/HOL/Hoare/Hoare_Logic_Abort" "../Sep_Heap_Instance"
          "../Sep_Tactics"
begin

declare [[syntax_ambiguity_warning = false]]

type_synonym heap = "(nat \<Rightarrow> nat option)"

(* This syntax isn't ideal, but this is what is used in the original *)
definition maps_to:: "nat \<Rightarrow> nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> _" [56,51] 56)
  where "x \<mapsto> y \<equiv> \<lambda>h. h = [x \<mapsto> y]"

(* If you don't mind syntax ambiguity: *)
notation pred_ex  (binder "\<exists>" 10)

(* could be generated automatically *)
definition maps_to_ex :: "nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> -" [56] 56)
  where "x \<mapsto> - \<equiv> \<exists>y. x \<mapsto> y"

(* could be generated automatically *)
lemma maps_to_maps_to_ex [elim!]:
  "(p \<mapsto> v) s \<Longrightarrow> (p \<mapsto> -) s"
  by (auto simp: maps_to_ex_def)

(* The basic properties of maps_to: *)
lemma maps_to_write:
  "(p \<mapsto> - ** P) H \<Longrightarrow> (p \<mapsto> v ** P) (H (p \<mapsto> v))"
  apply (clarsimp simp: sep_conj_def maps_to_def maps_to_ex_def split: option.splits)
  apply (rule_tac x=y in exI)
  apply (auto simp: sep_disj_fun_def map_convs map_add_def split: option.splits)
  done

lemma points_to:
  "(p \<mapsto> v ** P) H \<Longrightarrow> the (H p) = v"
  by (auto elim!: sep_conjE
           simp: sep_disj_fun_def maps_to_def map_convs map_add_def
           split: option.splits)

(* This differs from the original and uses separation logic for the definition. *)
primrec
  list :: "nat \<Rightarrow> nat list \<Rightarrow> heap \<Rightarrow> bool"
where
  "list i [] = (\<langle>i=0\<rangle> and \<box>)"
| "list i (x#xs) = (\<langle>i=x \<and> i\<noteq>0\<rangle> and (EXS j. i \<mapsto> j ** list j xs))"

lemma list_empty [simp]:
  shows "list 0 xs = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (cases xs) auto

(* The examples from Hoare/Separation.thy *)
lemma "VARS x y z w h
 {(x \<mapsto> y ** z \<mapsto> w) h}
 SKIP
 {x \<noteq> z}"
  apply vcg
  apply(auto elim!: sep_conjE simp: maps_to_def sep_disj_fun_def domain_conv)
done

lemma "VARS H x y z w
 {(P ** Q) H}
 SKIP
 {(Q ** P) H}"
  apply vcg
  apply(simp add: sep_conj_commute)
done

lemma "VARS H
 {p\<noteq>0 \<and> (p \<mapsto> - ** list q qs) H}
 H := H(p \<mapsto> q)
 {list p (p#qs) H}"
  apply vcg
  apply (auto intro: maps_to_write)
done

lemma "VARS H p q r
  {(list p Ps ** list q Qs) H}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (list p ps ** list q qs) H \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {list q (rev Ps @ Qs) H}"
  apply vcg
    apply fastforce
   apply clarsimp
   apply (case_tac ps, simp)
   apply (rename_tac p ps')
   apply (clarsimp simp: sep_conj_exists sep_conj_ac)
   apply (sep_subst points_to)
   apply (rule_tac x = "ps'" in exI)
   apply (rule_tac x = "p # qs" in exI)
   apply (simp add: sep_conj_exists sep_conj_ac)
   apply (rule exI)
   apply (sep_rule maps_to_write)
   apply ((sep_cancel add: maps_to_maps_to_ex)+)[1]
  apply clarsimp
  done

end


theory "Nominal-Utils"
imports Nominal2.Nominal2 "HOL-Library.AList"
begin

subsubsection \<open>Lemmas helping with equivariance proofs\<close>

lemma perm_rel_lemma:
  assumes "\<And> \<pi> x y. r (\<pi> \<bullet> x) (\<pi> \<bullet> y) \<Longrightarrow> r x y"
  shows "r (\<pi> \<bullet> x) (\<pi> \<bullet> y) \<longleftrightarrow> r x y" (is "?l \<longleftrightarrow> ?r")
by (metis (full_types) assms permute_minus_cancel(2))

lemma perm_rel_lemma2:
  assumes "\<And> \<pi> x y. r x y \<Longrightarrow> r (\<pi> \<bullet> x) (\<pi> \<bullet> y)"
  shows "r x y \<longleftrightarrow> r (\<pi> \<bullet> x) (\<pi> \<bullet> y)" (is "?l \<longleftrightarrow> ?r")
by (metis (full_types) assms permute_minus_cancel(2))

lemma fun_eqvtI:
  assumes f_eqvt[eqvt]: "(\<And> p x. p \<bullet> (f x) = f (p \<bullet> x))"
  shows "p \<bullet> f = f" by perm_simp rule

lemma eqvt_at_apply:
  assumes "eqvt_at f x"
  shows "(p \<bullet> f) x = f x"
by (metis (hide_lams, no_types) assms eqvt_at_def permute_fun_def permute_minus_cancel(1))

lemma eqvt_at_apply':
  assumes "eqvt_at f x"
  shows "p \<bullet> f x = f (p \<bullet> x)"
by (metis (hide_lams, no_types) assms eqvt_at_def)

lemma eqvt_at_apply'':
  assumes "eqvt_at f x"
  shows "(p \<bullet> f) (p \<bullet> x) = f (p \<bullet> x)"
by (metis (hide_lams, no_types) assms eqvt_at_def permute_fun_def permute_minus_cancel(1))

lemma size_list_eqvt[eqvt]: "p \<bullet> size_list f x = size_list (p \<bullet> f) (p \<bullet> x)"
proof (induction x)
  case (Cons x xs)
  have "f x = p \<bullet> (f x)" by (simp add: permute_pure)
  also have "... = (p \<bullet> f) (p \<bullet> x)" by simp
  with Cons
  show ?case by (auto simp add: permute_pure)
qed simp

subsubsection \<open>Freshness via equivariance\<close>

lemma eqvt_fresh_cong1: "(\<And>p x. p \<bullet> (f x) = f (p \<bullet> x)) \<Longrightarrow> a \<sharp> x \<Longrightarrow> a \<sharp> f x "
  apply (rule fresh_fun_eqvt_app[of f])
  apply (rule eqvtI)
  apply (rule eq_reflection)
  apply (rule ext)
  apply (metis permute_fun_def permute_minus_cancel(1))
  apply assumption
  done

lemma eqvt_fresh_cong2:
  assumes eqvt: "(\<And>p x y. p \<bullet> (f x y) = f (p \<bullet> x) (p \<bullet> y))"
  and fresh1: "a \<sharp> x" and fresh2: "a \<sharp> y"
  shows "a \<sharp> f x y"
proof-
  have "eqvt (\<lambda> (x,y). f x y)"
    using eqvt
    apply -
    apply (auto simp add: eqvt_def)
    apply (rule ext)
    apply auto
    by (metis permute_minus_cancel(1))
  moreover
  have "a \<sharp> (x, y)" using fresh1 fresh2 by auto
  ultimately
  have "a \<sharp> (\<lambda> (x,y). f x y) (x, y)" by (rule fresh_fun_eqvt_app)
  thus ?thesis by simp
qed

lemma eqvt_fresh_star_cong1:
  assumes eqvt: "(\<And>p x. p \<bullet> (f x) = f (p \<bullet> x))"
  and fresh1: "a \<sharp>* x"
  shows "a \<sharp>* f x"
  by (metis fresh_star_def eqvt_fresh_cong1 assms)

lemma eqvt_fresh_star_cong2:
  assumes eqvt: "(\<And>p x y. p \<bullet> (f x y) = f (p \<bullet> x) (p \<bullet> y))"
  and fresh1: "a \<sharp>* x" and fresh2: "a \<sharp>* y"
  shows "a \<sharp>* f x y"
  by (metis fresh_star_def eqvt_fresh_cong2 assms)

lemma eqvt_fresh_cong3:
  assumes eqvt: "(\<And>p x y z. p \<bullet> (f x y z) = f (p \<bullet> x) (p \<bullet> y) (p \<bullet> z))"
  and fresh1: "a \<sharp> x" and fresh2: "a \<sharp> y" and fresh3: "a \<sharp> z"
  shows "a \<sharp> f x y z"
proof-
  have "eqvt (\<lambda> (x,y,z). f x y z)"
    using eqvt
    apply -
    apply (auto simp add: eqvt_def)
    apply (rule ext)
    apply auto
    by (metis permute_minus_cancel(1))
  moreover
  have "a \<sharp> (x, y, z)" using fresh1 fresh2 fresh3 by auto
  ultimately
  have "a \<sharp> (\<lambda> (x,y,z). f x y z) (x, y, z)" by (rule fresh_fun_eqvt_app)
  thus ?thesis by simp
qed

lemma eqvt_fresh_star_cong3:
  assumes eqvt: "(\<And>p x y z. p \<bullet> (f x y z) = f (p \<bullet> x) (p \<bullet> y) (p \<bullet> z))"
  and fresh1: "a \<sharp>* x" and fresh2: "a \<sharp>* y" and fresh3: "a \<sharp>* z"
  shows "a \<sharp>* f x y z"
  by (metis fresh_star_def eqvt_fresh_cong3 assms)

subsubsection \<open>Additional simplification rules\<close>

lemma not_self_fresh[simp]: "atom x \<sharp> x \<longleftrightarrow> False"
  by (metis fresh_at_base(2))

lemma fresh_star_singleton: "{ x } \<sharp>* e \<longleftrightarrow> x \<sharp> e"
  by (simp add: fresh_star_def)

subsubsection \<open>Additional equivariance lemmas\<close>

lemma eqvt_cases:
  fixes f x \<pi>
  assumes eqvt: "\<And>x. \<pi> \<bullet> f x = f (\<pi> \<bullet> x)"
  obtains "f x" "f (\<pi> \<bullet> x)" | "\<not> f x " " \<not> f (\<pi> \<bullet> x)"
  using assms[symmetric]
   by (cases "f x") auto

lemma range_eqvt: "\<pi> \<bullet> range Y = range (\<pi> \<bullet> Y)"
  unfolding image_eqvt UNIV_eqvt ..

lemma case_option_eqvt[eqvt]:
  "\<pi> \<bullet> case_option d f x = case_option (\<pi> \<bullet> d) (\<pi> \<bullet> f) (\<pi> \<bullet> x)"
  by(cases x)(simp_all)

lemma supp_option_eqvt:
  "supp (case_option d f x) \<subseteq> supp d \<union> supp f \<union> supp x"
  apply (cases x)
  apply (auto simp add: supp_Some )
  apply (metis (mono_tags) Un_iff subsetCE supp_fun_app)
  done

lemma funpow_eqvt[simp,eqvt]:
  "\<pi> \<bullet> ((f :: 'a \<Rightarrow> 'a::pt) ^^ n) = (\<pi> \<bullet> f) ^^ (\<pi> \<bullet> n)"
 apply (induct n)
 apply simp
 apply (rule ext)
 apply simp
 apply perm_simp
 apply simp
 done

lemma delete_eqvt[eqvt]:
  "\<pi> \<bullet> AList.delete x \<Gamma> = AList.delete (\<pi> \<bullet> x) (\<pi> \<bullet> \<Gamma>)"
by (induct \<Gamma>, auto)

lemma restrict_eqvt[eqvt]:
  "\<pi> \<bullet> AList.restrict S \<Gamma> = AList.restrict (\<pi> \<bullet> S) (\<pi> \<bullet> \<Gamma>)"
unfolding AList.restrict_eq by perm_simp rule

lemma supp_restrict:
  "supp (AList.restrict S \<Gamma>) \<subseteq> supp \<Gamma>"
 by (induction \<Gamma>) (auto simp add: supp_Pair supp_Cons)

lemma clearjunk_eqvt[eqvt]:
  "\<pi> \<bullet> AList.clearjunk \<Gamma> = AList.clearjunk (\<pi> \<bullet> \<Gamma>)"
  by (induction \<Gamma> rule: clearjunk.induct) auto

lemma map_ran_eqvt[eqvt]:
  "\<pi> \<bullet> map_ran f \<Gamma> = map_ran (\<pi> \<bullet> f) (\<pi> \<bullet> \<Gamma>)"
by (induct \<Gamma>, auto)

lemma dom_perm:
  "dom (\<pi> \<bullet> f) = \<pi> \<bullet> (dom f)"
  unfolding dom_def by (perm_simp) (simp)

lemmas dom_perm_rev[simp,eqvt] = dom_perm[symmetric]

lemma ran_perm[simp]:
  "\<pi> \<bullet> (ran f) = ran (\<pi> \<bullet> f)"
  unfolding ran_def by (perm_simp) (simp)

lemma map_add_eqvt[eqvt]:
  "\<pi> \<bullet> (m1 ++ m2) = (\<pi> \<bullet> m1) ++ (\<pi> \<bullet> m2)"
  unfolding map_add_def
  by (perm_simp, rule)

lemma map_of_eqvt[eqvt]:
  "\<pi> \<bullet> map_of l = map_of (\<pi> \<bullet> l)"
  apply (induct l)
  apply (simp add: permute_fun_def)
  apply simp
  apply perm_simp
  apply auto
  done

lemma concat_eqvt[eqvt]: "\<pi> \<bullet> concat l = concat (\<pi> \<bullet> l)"
  by (induction l)(auto simp add: append_eqvt)

lemma tranclp_eqvt[eqvt]: "\<pi> \<bullet> tranclp P v\<^sub>1 v\<^sub>2 = tranclp (\<pi> \<bullet> P) (\<pi> \<bullet> v\<^sub>1) (\<pi> \<bullet> v\<^sub>2)"
  unfolding tranclp_def by perm_simp rule

lemma rtranclp_eqvt[eqvt]: "\<pi> \<bullet> rtranclp P v\<^sub>1 v\<^sub>2 = rtranclp (\<pi> \<bullet> P) (\<pi> \<bullet> v\<^sub>1) (\<pi> \<bullet> v\<^sub>2)"
  unfolding rtranclp_def by perm_simp rule

lemma Set_filter_eqvt[eqvt]: "\<pi> \<bullet> Set.filter P S = Set.filter (\<pi> \<bullet> P) (\<pi> \<bullet> S)"
  unfolding Set.filter_def
  by perm_simp rule

lemma Sigma_eqvt'[eqvt]: "\<pi> \<bullet> Sigma = Sigma"
  apply (rule ext)
  apply (rule ext)
  apply (subst permute_fun_def)
  apply (subst permute_fun_def)
  unfolding Sigma_def
  apply perm_simp
  apply (simp add: permute_self)
  done

lemma override_on_eqvt[eqvt]:
  "\<pi> \<bullet> (override_on m1 m2 S) = override_on (\<pi> \<bullet> m1) (\<pi> \<bullet> m2) (\<pi> \<bullet> S)"
  by (auto simp add: override_on_def )

lemma card_eqvt[eqvt]:
  "\<pi> \<bullet> (card S) = card (\<pi> \<bullet> S)"
by (cases "finite S", induct rule: finite_induct) (auto simp add: card_insert_if mem_permute_iff permute_pure)

(* Helper lemmas provided by Christian Urban *)

lemma Projr_permute:
  assumes a: "\<exists>y. f = Inr y"
  shows "(p \<bullet> (Sum_Type.projr f)) = Sum_Type.projr (p \<bullet> f)"
using a by auto

subsubsection \<open>Freshness lemmas\<close>

lemma fresh_list_elem:
  assumes "a \<sharp> \<Gamma>"
  and "e \<in> set \<Gamma>"
  shows "a \<sharp> e"
using assms
by(induct \<Gamma>)(auto simp add: fresh_Cons)

lemma set_not_fresh:
  "x \<in> set L \<Longrightarrow> \<not>(atom x \<sharp> L)"
  by (metis fresh_list_elem not_self_fresh)

lemma pure_fresh_star[simp]: "a \<sharp>* (x :: 'a :: pure)"
  by (simp add: fresh_star_def pure_fresh)

lemma supp_set_mem: "x \<in> set L \<Longrightarrow> supp x \<subseteq> supp L"
  by (induct L) (auto simp add: supp_Cons)

lemma set_supp_mono: "set L \<subseteq> set L2 \<Longrightarrow> supp L \<subseteq> supp L2"
  by (induct L)(auto simp add: supp_Cons supp_Nil dest:supp_set_mem)

lemma fresh_star_at_base:
  fixes x :: "'a :: at_base"
  shows "S \<sharp>* x \<longleftrightarrow> atom x \<notin> S"
  by (metis fresh_at_base(2) fresh_star_def)

subsubsection \<open>Freshness and support for subsets of variables\<close>

lemma supp_mono: "finite (B::'a::fs set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> supp A \<subseteq> supp B"
  by (metis infinite_super subset_Un_eq supp_of_finite_union)

lemma fresh_subset:
  "finite B \<Longrightarrow> x \<sharp> (B :: 'a::at_base set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<sharp> A"
  by (auto dest:supp_mono simp add: fresh_def)

lemma fresh_star_subset:
  "finite B \<Longrightarrow> x \<sharp>* (B :: 'a::at_base set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<sharp>* A"
  by (metis fresh_star_def fresh_subset)

lemma fresh_star_set_subset:
  "x \<sharp>* (B :: 'a::at_base list) \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> x \<sharp>* A"
  by (metis fresh_star_set fresh_star_subset[OF finite_set])

subsubsection \<open>The set of free variables of an expression\<close>

definition fv :: "'a::pt \<Rightarrow> 'b::at_base set"
  where "fv e = {v. atom v \<in> supp e}"

lemma fv_eqvt[simp,eqvt]: "\<pi> \<bullet> (fv e) = fv (\<pi> \<bullet> e)"
  unfolding fv_def by simp

lemma fv_Nil[simp]: "fv [] = {}"
  by (auto simp add: fv_def supp_Nil)
lemma fv_Cons[simp]: "fv (x # xs) = fv x \<union> fv xs"
  by (auto simp add: fv_def supp_Cons)
lemma fv_Pair[simp]: "fv (x, y) = fv x \<union> fv y"
  by (auto simp add: fv_def supp_Pair)
lemma fv_append[simp]: "fv (x @ y) = fv x \<union> fv y"
  by (auto simp add: fv_def supp_append)
lemma fv_at_base[simp]: "fv a = {a::'a::at_base}"
  by (auto simp add: fv_def supp_at_base)
lemma fv_pure[simp]: "fv (a::'a::pure) = {}"
  by (auto simp add: fv_def pure_supp)

lemma fv_set_at_base[simp]: "fv (l :: ('a :: at_base) list) = set l"
  by (induction l) auto

lemma flip_not_fv: "a \<notin> fv x \<Longrightarrow> b \<notin> fv x \<Longrightarrow> (a \<leftrightarrow> b) \<bullet> x = x"
  by (metis flip_def fresh_def fv_def mem_Collect_eq swap_fresh_fresh)

lemma fv_not_fresh: "atom x \<sharp> e \<longleftrightarrow> x \<notin> fv e"
  unfolding fv_def fresh_def by blast

lemma fresh_fv: "finite (fv e :: 'a set) \<Longrightarrow>  atom (x :: ('a::at_base)) \<sharp> (fv e :: 'a set) \<longleftrightarrow> atom x \<sharp> e"
  unfolding fv_def fresh_def
  by (auto simp add: supp_finite_set_at_base)

lemma finite_fv[simp]: "finite (fv (e::'a::fs) :: ('b::at_base) set)"
proof-
  have "finite (supp e)" by (metis finite_supp)
  hence "finite (atom -` supp e :: 'b set)"
    apply (rule finite_vimageI)
    apply (rule inj_onI)
    apply (simp)
    done
  moreover
  have "(atom -` supp e  :: 'b set) = fv e"   unfolding fv_def by auto
  ultimately
  show ?thesis by simp
qed

definition fv_list :: "'a::fs \<Rightarrow> 'b::at_base list"
  where "fv_list e = (SOME l. set l = fv e)"

lemma fresh_fv_list[simp]:
  "a \<sharp> (fv_list e :: 'b::at_base list) \<longleftrightarrow> a \<sharp> (fv e :: 'b::at_base set)"
proof-
  have "a \<sharp> (fv_list e :: 'b::at_base list) \<longleftrightarrow> a \<sharp> set (fv_list e :: 'b::at_base list)"
    by (rule fresh_set[symmetric])
  also have "\<dots> \<longleftrightarrow> a \<sharp> (fv e :: 'b::at_base set)" by simp
  finally show ?thesis.
qed

subsubsection \<open>Other useful lemmas\<close>

lemma pure_permute_id: "permute p = (\<lambda> x. (x::'a::pure))"
  by rule (simp add: permute_pure)

lemma supp_set_elem_finite:
  assumes "finite S"
  and "(m::'a::fs) \<in> S"
  and "y \<in> supp m"
  shows "y \<in> supp S"
  using assms supp_of_finite_sets
  by auto

lemmas fresh_star_Cons = fresh_star_list(2)

lemma mem_permute_set:
  shows "x \<in> p \<bullet> S \<longleftrightarrow> (- p \<bullet> x) \<in> S"
  by (metis mem_permute_iff permute_minus_cancel(2))

lemma flip_set_both_not_in:
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "((x' \<leftrightarrow> x) \<bullet> S) = S"
  unfolding permute_set_def
  by (auto) (metis assms flip_at_base_simps(3))+

lemma inj_atom: "inj atom" by (metis atom_eq_iff injI)

lemmas image_Int[OF inj_atom, simp]

lemma eqvt_uncurry: "eqvt f \<Longrightarrow> eqvt (case_prod f)"
  unfolding eqvt_def
  by perm_simp simp

lemma supp_fun_app_eqvt2:
  assumes a: "eqvt f"
  shows "supp (f x y) \<subseteq> supp x \<union> supp y"
proof-
  from supp_fun_app_eqvt[OF eqvt_uncurry [OF a]]
  have "supp (case_prod f (x,y)) \<subseteq> supp (x,y)".
  thus ?thesis by (simp add: supp_Pair)
qed

lemma supp_fun_app_eqvt3:
  assumes a: "eqvt f"
  shows "supp (f x y z) \<subseteq> supp x \<union> supp y \<union> supp z"
proof-
  from supp_fun_app_eqvt2[OF eqvt_uncurry [OF a]]
  have "supp (case_prod f (x,y) z) \<subseteq> supp (x,y) \<union> supp z".
  thus ?thesis by (simp add: supp_Pair)
qed

(* Fighting eta-contraction *)
lemma permute_0[simp]: "permute 0 = (\<lambda> x. x)"
  by auto
lemma permute_comp[simp]: "permute x \<circ> permute y = permute (x + y)" by auto

lemma map_permute: "map (permute p) = permute p"
  apply rule
  apply (induct_tac x)
  apply auto
  done

lemma fresh_star_restrictA[intro]: "a \<sharp>* \<Gamma> \<Longrightarrow> a \<sharp>* AList.restrict V \<Gamma>"
  by (induction \<Gamma>) (auto simp add: fresh_star_Cons)

(* Unused. Still submit? *)
lemma Abs_lst_Nil_eq[simp]: "[[]]lst. (x::'a::fs) = [xs]lst. x' \<longleftrightarrow> (([],x) = (xs, x'))"
  apply rule
  apply (frule Abs_lst_fcb2[where f = "\<lambda> x y _ . (x,y)" and as = "[]" and bs = "xs" and c = "()"])
  apply (auto simp add: fresh_star_def)
  done

(* Unused. Still submit? *)
lemma Abs_lst_Nil_eq2[simp]: "[xs]lst. (x::'a::fs) = [[]]lst. x' \<longleftrightarrow> ((xs,x) = ([], x'))"
  by (subst eq_commute) auto

end


section \<open>Implementations of the SPY-Method\<close>

theory SPY_Method_Implementations
imports Intermediate_Frameworks Pair_Framework "../Distinguishability" Test_Suite_Representations "../OFSM_Tables_Refined" "HOL-Library.List_Lexorder"
begin

subsection \<open>Using the H-Framework\<close>

definition spy_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "spy_method_via_h_framework M m = h_framework_static_with_simple_graph M (\<lambda> k q . get_HSI M q) m"

definition spy_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "spy_method_via_h_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (spy_method_via_h_framework M m))"

lemma spy_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spy_method_via_h_framework M1 m)) = (L M2 \<inter> set (spy_method_via_h_framework M1 m)))"
and "finite_tree (spy_method_via_h_framework M1 m)"
  using h_framework_static_with_simple_graph_completeness_and_finiteness[OF assms, where dist_fun="(\<lambda> k q . get_HSI M1 q)"]
  using get_HSI_distinguishes[OF assms(1,3)]
  using get_HSI_finite
  unfolding spy_method_via_h_framework_def
  by blast+

lemma spy_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (spy_method_via_h_framework_lists M1 m)"
  using h_framework_static_with_simple_graph_lists_completeness[OF assms, where dist_fun="(\<lambda> k q . get_HSI M1 q)", OF _ get_HSI_finite]
  using get_HSI_distinguishes[OF assms(1,3)]
  unfolding spy_method_via_h_framework_lists_def h_framework_static_with_simple_graph_lists_def spy_method_via_h_framework_def
  by blast

subsection \<open>Using the SPY-Framework\<close>

definition spy_method_via_spy_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "spy_method_via_spy_framework M m = spy_framework_static_with_simple_graph M (\<lambda> k q . get_HSI M q) m"

lemma spy_method_via_spy_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spy_method_via_spy_framework M1 m)) = (L M2 \<inter> set (spy_method_via_spy_framework M1 m)))"
and "finite_tree (spy_method_via_spy_framework M1 m)"
  unfolding spy_method_via_spy_framework_def
  using spy_framework_static_with_simple_graph_completeness_and_finiteness[OF assms, of "(\<lambda> k q . get_HSI M1 q)"]
  using get_HSI_distinguishes[OF assms(1,3)]
  using get_HSI_finite[of M1]
  by blast+

definition spy_method_via_spy_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "spy_method_via_spy_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (spy_method_via_spy_framework M m))"

lemma spy_method_via_spy_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (spy_method_via_spy_framework_lists M1 m)"
  unfolding spy_method_via_spy_framework_lists_def
            spy_method_via_spy_framework_completeness_and_finiteness(1)[OF assms]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial spy_method_via_spy_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Code Generation\<close>

lemma spy_method_via_spy_framework_code[code] :
  "spy_method_via_spy_framework M m = (let
    tables = (compute_ofsm_tables M (size M - 1));
    distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                      (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
    distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);

    hsiMap = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . distHelper q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M));
    distFun = (\<lambda> k q . if q \<in> states M then the (Mapping.lookup hsiMap q) else get_HSI M q)
  in spy_framework_static_with_simple_graph M distFun m)"
(is "?f1 = ?f2")
proof -

  define hsiMap' where "hsiMap' = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun' where "distFun' = (\<lambda> M q . if q \<in> states M then the (Mapping.lookup hsiMap' q) else get_HSI M q)"

  have *: "?f2 = spy_framework_static_with_simple_graph M (\<lambda> k q . distFun' M q) m"
    unfolding distFun'_def hsiMap'_def Let_def
    apply (subst (2) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
    unfolding Let_def
    by presburger

  define hsiMap where "hsiMap = map_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun where "distFun = (\<lambda> M q . if q \<in> states M then the (hsiMap q) else get_HSI M q)"

  have "distinct (map fst (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M)))"
    using states_as_list_distinct
    by (metis map_pair_fst)
  then have "Mapping.lookup hsiMap' = hsiMap"
    unfolding hsiMap_def hsiMap'_def
    using mapping_of_map_of
    by blast
  then have "distFun' = distFun"
    unfolding distFun_def distFun'_def by meson

  have **:"distFun M = get_HSI M"
  proof
    fix q show "distFun M q = get_HSI M q"
    proof (cases "q \<in> states M")
      case True
      then have "q \<in> list.set (states_as_list M)"
        using states_as_list_set by blast
      then show ?thesis
        unfolding distFun_def hsiMap_def map_of_map_pair_entry get_HSI.simps
        using True
        by fastforce
    next
      case False
      then show ?thesis using distFun_def by auto
    qed
  qed

  show ?thesis
    unfolding * ** \<open>distFun' = distFun\<close> spy_method_via_spy_framework_def by simp
qed

lemma spy_method_via_h_framework_code[code] :
  "spy_method_via_h_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);

      hsiMap = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . distHelper q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M));
      distFun = (\<lambda> k q . if q \<in> states M then the (Mapping.lookup hsiMap q) else get_HSI M q)
    in h_framework_static_with_simple_graph M distFun m)"
(is "?f1 = ?f2")
proof -

  define hsiMap' where "hsiMap' = mapping_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun' where "distFun' = (\<lambda> M q . if q \<in> states M then the (Mapping.lookup hsiMap' q) else get_HSI M q)"

  have *: "?f2 = h_framework_static_with_simple_graph M (\<lambda> k q . distFun' M q) m"
    unfolding distFun'_def hsiMap'_def Let_def
    apply (subst (2) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
    unfolding Let_def
    by presburger

  define hsiMap where "hsiMap = map_of (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M))"
  define distFun where "distFun = (\<lambda> M q . if q \<in> states M then the (hsiMap q) else get_HSI M q)"

  have "distinct (map fst (map (\<lambda> q . (q,from_list (map (\<lambda>q' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((\<noteq>) q) (states_as_list M))))) (states_as_list M)))"
    using states_as_list_distinct
    by (metis map_pair_fst)
  then have "Mapping.lookup hsiMap' = hsiMap"
    unfolding hsiMap_def hsiMap'_def
    using mapping_of_map_of
    by blast
  then have "distFun' = distFun"
    unfolding distFun_def distFun'_def by meson

  have **:"distFun M = get_HSI M"
  proof
    fix q show "distFun M q = get_HSI M q"
    proof (cases "q \<in> states M")
      case True
      then have "q \<in> list.set (states_as_list M)"
        using states_as_list_set by blast
      then show ?thesis
        unfolding distFun_def hsiMap_def map_of_map_pair_entry get_HSI.simps
        using True
        by fastforce
    next
      case False
      then show ?thesis using distFun_def by auto
    qed
  qed

  show ?thesis
    unfolding * ** \<open>distFun' = distFun\<close> spy_method_via_h_framework_def by simp
qed

end


section \<open> Minimal Mereology \<close>

(*<*)
theory MM
  imports M
begin
(*>*)

text \<open> Minimal mereology adds to ground mereology the axiom of weak supplementation.\footnote{
See \<^cite>\<open>"varzi_parts_1996"\<close> and \<^cite>\<open>"casati_parts_1999"\<close> p. 39. The name \emph{minimal mereology}
reflects the, controversial, idea that weak supplementation is analytic. See, for example, \<^cite>\<open>"simons_parts:_1987"\<close>
p. 116, \<^cite>\<open>"varzi_extensionality_2008"\<close> p. 110-1, and \<^cite>\<open>"cotnoir_is_2018"\<close>. For general
discussion of weak supplementation see, for example \<^cite>\<open>"smith_mereology_2009"\<close> pp. 507 and
\<^cite>\<open>"donnelly_using_2011"\<close>.} \<close>

locale MM = M +
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"

text \<open> The rest of this section considers three alternative axiomatizations of minimal mereology. The
first alternative axiomatization replaces improper with proper parthood in the consequent of weak
supplementation.\footnote{See \<^cite>\<open>"simons_parts:_1987"\<close> p. 28.} \<close>

locale MM1 = M +
  assumes proper_weak_supplementation:
    "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> O z y)"

sublocale MM \<subseteq> MM1
proof
  fix x y
  show "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> O z y)"
  proof -
    assume "PP y x"
    hence "\<exists> z. P z x \<and> \<not> O z y" by (rule weak_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "\<not> O z y"..
    from z have "P z x"..
    hence "P z x \<and> z \<noteq> x"
    proof
      show "z \<noteq> x"
      proof
        assume "z = x"
        hence "PP y z"
          using \<open>PP y x\<close> by (rule ssubst)
        hence "O y z" by (rule proper_implies_overlap)
        hence "O z y" by (rule overlap_symmetry)
        with \<open>\<not> O z y\<close> show "False"..
      qed
    qed
    with nip_eq have "PP z x"..
    hence "PP z x \<and> \<not> O z y"
      using \<open>\<not> O z y\<close>..
    thus "\<exists> z. PP z x \<and> \<not> O z y"..
  qed
qed

sublocale MM1 \<subseteq> MM
proof
  fix x y
  show weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
  proof -
    assume "PP y x"
    hence "\<exists> z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
    then obtain z where z: "PP z x \<and> \<not> O z y"..
    hence "PP z x"..
    hence "P z x" by (rule proper_implies_part)
    moreover from z have "\<not> O z y"..
    ultimately have "P z x \<and> \<not> O z y"..
    thus "\<exists> z. P z x \<and> \<not> O z y"..
  qed
qed

text \<open> The following two corollaries are sometimes found in the literature.\footnote{See \<^cite>\<open>"simons_parts:_1987"\<close> p. 27. For the names \emph{weak company}
and \emph{strong company} see \<^cite>\<open>"cotnoir_non-wellfounded_2012"\<close> p. 192-3 and \<^cite>\<open>"varzi_mereology_2016"\<close>.} \<close>

context MM
begin

corollary weak_company: "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> z \<noteq> y)"
proof -
  assume "PP y x"
  hence "\<exists> z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
  then obtain z where z: "PP z x \<and> \<not> O z y"..
  hence "PP z x"..
  from z have "\<not> O z y"..
  hence "z \<noteq> y" by (rule disjoint_implies_distinct)
  with \<open>PP z x\<close> have "PP z x \<and> z \<noteq> y"..
  thus "\<exists> z. PP z x \<and> z \<noteq> y"..
qed

corollary strong_company: "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> P z y)"
proof -
  assume "PP y x"
  hence "\<exists>z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
  then obtain z where z: "PP z x \<and> \<not> O z y"..
  hence "PP z x"..
  from z have "\<not> O z y"..
  hence "\<not> P z y" by (rule disjoint_implies_not_part)
  with \<open>PP z x\<close> have  "PP z x \<and> \<not> P z y"..
  thus "\<exists> z. PP z x \<and> \<not> P z y"..
qed

end

text \<open> If weak supplementation is formulated in terms of nonidentical parthood, then the antisymmetry
of parthood is redundant, and we have the second alternative axiomatization of minimal mereology.\footnote{
See \<^cite>\<open>"cotnoir_antisymmetry_2010"\<close> p. 399, \<^cite>\<open>"donnelly_using_2011"\<close> p. 232,
\<^cite>\<open>"cotnoir_non-wellfounded_2012"\<close> p. 193 and \<^cite>\<open>"obojska_remarks_2013"\<close> pp. 235-6.} \<close>

locale MM2 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"

sublocale MM2 \<subseteq> MM
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    show "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      with \<open>P x y\<close> have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      hence "\<exists> z. P z y \<and> \<not> O z x" by (rule weak_supplementation)
      then obtain z where z: "P z y \<and> \<not> O z x"..
      hence "\<not> O z x"..
      hence "\<not> P z x" by (rule disjoint_implies_not_part)
      from z have "P z y"..
      hence "P z x" using \<open>P y x\<close> by (rule part_transitivity)
      with \<open>\<not> P z x\<close> show "False"..
    qed
  qed
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

sublocale MM \<subseteq> MM2
proof
  fix x y
  show "PP x y \<longleftrightarrow> (P x y \<and> x \<noteq> y)" using nip_eq.
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

text \<open> Likewise, if proper parthood is adopted as primitive, then the asymmetry of proper parthood
is redundant in the context of weak supplementation, leading to the third alternative
axiomatization.\footnote{See \<^cite>\<open>"donnelly_using_2011"\<close> p. 232 and \<^cite>\<open>"cotnoir_is_2018"\<close>.} \<close>

locale MM3 =
  assumes part_eq: "P x y \<longleftrightarrow> PP x y \<or> x = y"
  assumes overlap_eq: "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)"
  assumes proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
begin

lemma part_reflexivity: "P x x"
proof -
  have "x = x"..
  hence "PP x x \<or> x = x"..
  with part_eq show "P x x"..
qed

lemma proper_part_irreflexivity: "\<not> PP x x"
proof
  assume "PP x x"
  hence "\<exists> z. P z x \<and> \<not> O z x" by (rule weak_supplementation)
  then obtain z where z: "P z x \<and> \<not> O z x"..
  hence "\<not> O z x"..
  from z have "P z x"..
  with part_reflexivity have "P z z \<and> P z x"..
  hence "\<exists> v. P v z \<and> P v x"..
  with overlap_eq have "O z x"..
  with \<open>\<not> O z x\<close> show "False"..
qed

end

sublocale MM3 \<subseteq> M4
proof
  fix x y z
  show "P x y \<longleftrightarrow> PP x y \<or> x = y" using part_eq.
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show proper_part_irreflexivity: "PP x y \<Longrightarrow> \<not> PP y x"
  proof -
    assume "PP x y"
    show "\<not> PP y x"
    proof
      assume "PP y x"
      hence "PP y y" using \<open>PP x y\<close> by (rule proper_part_transitivity)
      with proper_part_irreflexivity show "False"..
    qed
  qed
  show "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z" using proper_part_transitivity.
qed

sublocale MM3 \<subseteq> MM
proof
  fix x y
  show "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)" using weak_supplementation.
qed

sublocale MM \<subseteq> MM3
proof
  fix x y z
  show "P x y \<longleftrightarrow> (PP x y \<or> x = y)" using part_eq.
  show "O x y \<longleftrightarrow> (\<exists>z. P z x \<and> P z y)" using overlap_eq.
  show "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z" using proper_part_transitivity.
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

(*<*) end (*>*)