section {* Proper Iterators *}
theory Proper_Iterator
imports
  "SetIteratorOperations"
  "../../Automatic_Refinement/Lib/Refine_Lib"
begin
  text {*
    Proper iterators provide a way to obtain polymorphic iterators even
    inside locale contexts.

    For this purpose, an iterator that converts the set to a list is fixed
    inside the locale, and polymorphic iterators are described by folding
    over the generated list.

    In order to ensure efficiency, it is shown that folding over the generated
    list is equivalent to directly iterating over the set, and this equivalence
    is set up as a code preprocessing rule.
    *}

  subsection {* Proper Iterators *}

  text {* A proper iterator can be expressed as a fold over a list, where
    the list does only depend on the set. In particular, it does not depend
    on the type of the state. We express this by the following definition,
    using two iterators with different types: *}

  definition proper_it
    :: "('x,'\<sigma>1) set_iterator \<Rightarrow> ('x,'\<sigma>2) set_iterator \<Rightarrow> bool"
    where "proper_it it it' \<equiv> (\<exists>l. it=foldli l \<and> it'=foldli l)"

  lemma proper_itI[intro?]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "it=foldli l \<and> it'=foldli l"
    shows "proper_it it it'"
    using assms unfolding proper_it_def by auto

  lemma proper_itE:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "proper_it it it'"
    obtains l where "it=foldli l" and "it'=foldli l"
    using assms unfolding proper_it_def by auto

  lemma proper_it_parE:
    fixes it :: "'a \<Rightarrow> ('x,'\<sigma>1) set_iterator"
    and it' :: "'a \<Rightarrow> ('x,'\<sigma>2) set_iterator"
    assumes "\<forall>x. proper_it (it x) (it' x)"
    obtains f where "it = (\<lambda>x. foldli (f x))" and "it' = (\<lambda>x. foldli (f x))"
    using assms unfolding proper_it_def
    by metis

  definition
    proper_it'
    where "proper_it' it it' \<equiv> \<forall>s. proper_it (it s) (it' s)"

  lemma proper_it'I:
    "\<lbrakk>\<And>s. proper_it (it s) (it' s)\<rbrakk> \<Longrightarrow> proper_it' it it'"
    unfolding proper_it'_def by blast

  lemma proper_it'D:
    "proper_it' it it' \<Longrightarrow> proper_it (it s) (it' s)"
    unfolding proper_it'_def by blast

  subsubsection {* Properness Preservation *}
  ML {*
    structure Icf_Proper_Iterator = struct

      structure icf_proper_iteratorI = Named_Thms
        ( val name = @{binding icf_proper_iteratorI_raw}
          val description = "ICF (internal): Rules to show properness of iterators" )

      val get = icf_proper_iteratorI.get

      fun add_thm thm = icf_proper_iteratorI.add_thm thm

      val add = Thm.declaration_attribute add_thm

      fun del_thm thm = icf_proper_iteratorI.del_thm thm

      val del = Thm.declaration_attribute del_thm

      val setup = I
        #> icf_proper_iteratorI.setup
        #> Attrib.setup @{binding icf_proper_iteratorI}
          (Attrib.add_del add del)
          ("ICF: Rules to show properness of iterators")
        #> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI},
             get o Context.proof_of
            )

    end
    *}
  setup {* Icf_Proper_Iterator.setup *}

  lemma proper_iterator_trigger:
    "proper_it it it' \<Longrightarrow> proper_it it it'"
    "proper_it' itf itf' \<Longrightarrow> proper_it' itf itf'" .

  declaration {*
    Tagged_Solver.declare_solver @{thms proper_iterator_trigger}
      @{binding proper_iterator} "Proper iterator solver"
      (fn ctxt => REPEAT_ALL_NEW (resolve_tac ctxt (Icf_Proper_Iterator.get ctxt)))
    *}

  lemma pi_foldli[icf_proper_iteratorI]:
    "proper_it (foldli l :: ('a,'\<sigma>) set_iterator) (foldli l)"
    unfolding proper_it_def
    by auto

  lemma pi_foldri[icf_proper_iteratorI]:
    "proper_it (foldri l :: ('a,'\<sigma>) set_iterator) (foldri l)"
    unfolding proper_it_def foldri_def by auto

  lemma pi'_foldli[icf_proper_iteratorI]:
    "proper_it' (foldli o tsl) (foldli o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  lemma pi'_foldri[icf_proper_iteratorI]:
    "proper_it' (foldri o tsl) (foldri o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  text {* Iterator combinators preserve properness *}
  lemma pi_emp[icf_proper_iteratorI]:
    "proper_it set_iterator_emp set_iterator_emp"
    unfolding proper_it_def set_iterator_emp_def[abs_def]
    by (auto intro!: ext exI[where x="[]"])

  lemma pi_sng[icf_proper_iteratorI]:
    "proper_it (set_iterator_sng x) (set_iterator_sng x)"
    unfolding proper_it_def set_iterator_sng_def[abs_def]
    by (auto intro!: ext exI[where x="[x]"])

  lemma pi_union[icf_proper_iteratorI]:
    assumes PA: "proper_it it_a it_a'"
    assumes PB: "proper_it it_b it_b'"
    shows "proper_it (set_iterator_union it_a it_b)
      (set_iterator_union it_a' it_b')"
    unfolding set_iterator_union_def
    apply (rule proper_itE[OF PA])
    apply (rule proper_itE[OF PB])
    apply (rule_tac l="l@la" in proper_itI)
    apply simp
    apply (intro conjI ext)
    apply (simp_all add: foldli_append)
    done

  lemma pi_product[icf_proper_iteratorI]:
    fixes it_a :: "('a,'\<sigma>a) set_iterator"
    fixes it_b :: "'a \<Rightarrow> ('b,'\<sigma>a) set_iterator"
    assumes PA: "proper_it it_a it_a'"
    and PB: "\<And>x. proper_it (it_b x) (it_b' x)"
    shows "proper_it (set_iterator_product it_a it_b)
      (set_iterator_product it_a' it_b')"
  proof -
    from PB have PB': "\<forall>x. proper_it (it_b x) (it_b' x)" ..
    show ?thesis
      unfolding proper_it_def
      apply (rule proper_itE[OF PA])
      apply (rule proper_it_parE[OF PB'])
      apply (auto simp add: set_iterator_product_foldli_conv)
      done
  qed

  lemma pi_image_filter[icf_proper_iteratorI]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    and g :: "'x \<Rightarrow> 'y option"
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image_filter g it)
      (set_iterator_image_filter g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    apply (auto simp: set_iterator_image_filter_foldli_conv)
    done

  lemma pi_filter[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_filter P it)
      (set_iterator_filter P it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_filter_foldli_conv)

  lemma pi_image[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image g it)
      (set_iterator_image g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_image_foldli_conv)

  lemma pi_dom[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (map_iterator_dom it)
      (map_iterator_dom it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: map_iterator_dom_foldli_conv)

  lemma set_iterator_product_eq2:
    assumes "\<forall>a\<in>set la. itb a = itb' a"
    shows "set_iterator_product (foldli la) itb
    = set_iterator_product (foldli la) itb'"
  proof (intro ext)
    fix c f \<sigma>
    show "set_iterator_product (foldli la) itb c f \<sigma>
      = set_iterator_product (foldli la) itb' c f \<sigma>"
      using assms
      unfolding set_iterator_product_def
      apply (induct la arbitrary: \<sigma>)
      apply (auto)
      done
  qed

subsubsection {* Optimizing Folds *}
  text {*
    Using an iterator to create a list. The optimizations will
    match the pattern @{text "foldli (it_to_list it s)"}
    *}
  definition "it_to_list it s \<equiv> (it s) (\<lambda>_. True) (\<lambda>x l. l@[x]) []"

  lemma map_it_to_list_genord_correct:
    assumes A: "map_iterator_genord (it s) m (\<lambda>(k,_) (k',_). R k k')"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted_by_rel R ((map fst (it_to_list it s)))"
    unfolding it_to_list_def
    apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
      \<lambda>it l. map_of l = m |` it
        \<and> distinct (map fst l)
        \<and> sorted_by_rel R ((map fst l))
      "])
    apply auto
    apply (auto intro!: ext simp: restrict_map_def) []
    apply (metis Some_eq_map_of_iff restrict_map_eq(2))
    apply (auto simp add: sorted_by_rel_append)
    by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)

  lemma (in linorder) map_it_to_list_linord_correct:
    assumes A: "map_iterator_linord (it s) m"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted ((map fst (it_to_list it s)))"
    using map_it_to_list_genord_correct[where it=it,
      OF A[unfolded set_iterator_map_linord_def]]
    by simp

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Combined beta and eta reduction of lambda terms\<close>

theory Beta_Eta
imports "~~/src/HOL/Proofs/Lambda/Eta" Joinable
begin

subsubsection \<open>Auxiliary lemmas\<close>

lemma liftn_lift_swap: "liftn n (lift t k) k = lift (liftn n t k) k"
by (induction n) simp_all

lemma subst_liftn:
  "i \<le> n + k \<and> k \<le> i \<Longrightarrow> (liftn (Suc n) s k)[t/i] = liftn n s k"
by (induction s arbitrary: i k t) auto

lemma subst_lift2[simp]: "(lift (lift t 0) 0)[x/Suc 0] = lift t 0"
proof -
  have "lift (lift t 0) 0 = lift (lift t 0) (Suc 0)" using lift_lift by simp
  thus ?thesis by simp
qed

lemma free_liftn:
  "free (liftn n t k) i = (i < k \<and> free t i \<or> k + n \<le> i \<and> free t (i - n))"
by (induction t arbitrary: k i) (auto simp add: Suc_diff_le)

subsubsection \<open>Reduction\<close>

abbreviation beta_eta :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<rightarrow>\<^sub>\<beta>\<^sub>\<eta>" 50)
where "beta_eta \<equiv> sup beta eta"

abbreviation beta_eta_reds :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>*" 50)
where "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<equiv> (beta_eta)\<^sup>*\<^sup>* s t"

lemma beta_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by auto

lemma eta_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by auto

lemma beta_reds_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by (auto intro: rtranclp_mono[THEN predicate2D])

lemma eta_reds_into_beta_eta_reds: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t"
by (auto intro: rtranclp_mono[THEN predicate2D])

lemma beta_eta_appL[intro]: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s' \<degree> t"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_appR[intro]: "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* s \<degree> t'"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_abs[intro]: "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t' \<Longrightarrow> Abs t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* Abs t'"
by (induction set: rtranclp) (auto intro: rtranclp.rtrancl_into_rtrancl)

lemma beta_eta_lift: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> lift s k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* lift t k"
proof (induction pred: rtranclp)
  case base show ?case ..
next
  case (step y z)
  hence "lift y k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta> lift z k" using lift_preserves_beta eta_lift by blast
  with step.IH show "lift s k \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* lift z k" by iprover
qed

lemma confluent_beta_eta_reds: "Joinable.confluent {(s, t). s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t}"
using confluent_beta_eta
unfolding diamond_def commute_def square_def
by (blast intro!: confluentI)

subsubsection \<open>Equivalence\<close>

text \<open>Terms are equivalent iff they can be reduced to a common term.\<close>

definition term_equiv :: "dB \<Rightarrow> dB \<Rightarrow> bool" (infixl "\<leftrightarrow>" 50)
where "term_equiv = joinablep beta_eta_reds"

lemma term_equivI:
  assumes "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u" and "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u"
  shows "s \<leftrightarrow> t"
using assms unfolding term_equiv_def by (rule joinableI[to_pred])

lemma term_equivE:
  assumes "s \<leftrightarrow> t"
  obtains u where "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u" and "t \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* u"
using assms unfolding term_equiv_def by (rule joinableE[to_pred])

lemma reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (blast intro: term_equivI)

lemma beta_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule beta_into_beta_eta_reds)

lemma eta_into_equiv[elim]: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule eta_into_beta_eta_reds)

lemma beta_reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule beta_reds_into_beta_eta_reds)

lemma eta_reds_into_equiv[elim]: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t \<Longrightarrow> s \<leftrightarrow> t"
by (rule reds_into_equiv) (rule eta_reds_into_beta_eta_reds)

lemma term_refl[iff]: "t \<leftrightarrow> t"
unfolding term_equiv_def by (blast intro: joinablep_refl reflpI)

lemma term_sym[sym]: "(s \<leftrightarrow> t) \<Longrightarrow> (t \<leftrightarrow> s)"
unfolding term_equiv_def by (rule joinable_sym[to_pred])

lemma conversep_term [simp]: "conversep (op \<leftrightarrow>) = op \<leftrightarrow>"
by (auto simp add: fun_eq_iff intro: term_sym)

lemma term_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<leftrightarrow> u \<Longrightarrow> s \<leftrightarrow> u"
unfolding term_equiv_def
using trans_joinable[to_pred] trans_rtrancl[to_pred] confluent_beta_eta_reds
by (blast elim: transpE)

lemma term_beta_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> u \<Longrightarrow> s \<leftrightarrow> u"
by (fast dest!: beta_into_beta_eta_reds intro: term_trans)

lemma term_eta_trans[trans]: "s \<leftrightarrow> t \<Longrightarrow> t \<rightarrow>\<^sub>\<eta> u \<Longrightarrow> s \<leftrightarrow> u"
by (fast dest!: eta_into_beta_eta_reds intro: term_trans)

lemma equiv_appL[intro]: "s \<leftrightarrow> s' \<Longrightarrow> s \<degree> t \<leftrightarrow> s' \<degree> t"
unfolding term_equiv_def using beta_eta_appL
by (iprover intro: joinable_subst[to_pred])

lemma equiv_appR[intro]: "t \<leftrightarrow> t' \<Longrightarrow> s \<degree> t \<leftrightarrow> s \<degree> t'"
unfolding term_equiv_def using beta_eta_appR
by (iprover intro: joinable_subst[to_pred])

lemma equiv_app: "s \<leftrightarrow> s' \<Longrightarrow> t \<leftrightarrow> t' \<Longrightarrow> s \<degree> t \<leftrightarrow> s' \<degree> t'"
by (blast intro: term_trans)

lemma equiv_abs[intro]: "t \<leftrightarrow> t' \<Longrightarrow> Abs t \<leftrightarrow> Abs t'"
unfolding term_equiv_def using beta_eta_abs
by (iprover intro: joinable_subst[to_pred])

lemma equiv_lift: "s \<leftrightarrow> t \<Longrightarrow> lift s k \<leftrightarrow> lift t k"
by (auto intro: term_equivI beta_eta_lift elim: term_equivE)

lemma equiv_liftn: "s \<leftrightarrow> t \<Longrightarrow> liftn n s k \<leftrightarrow> liftn n t k"
by (induction n) (auto intro: equiv_lift)

text \<open>Our definition is equivalent to the the symmetric and transitive closure of
  the reduction relation.\<close>

lemma equiv_eq_rtscl_reds: "term_equiv = (sup beta_eta beta_eta\<inverse>\<inverse>)\<^sup>*\<^sup>*"
unfolding term_equiv_def
using confluent_beta_eta_reds
by (rule joinable_eq_rtscl[to_pred])

end


section \<open> Reactive Conditions \<close>

theory utp_rea_cond
  imports utp_rea_rel
begin

subsection \<open> Healthiness Conditions \<close>

definition RC1 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "RC1(P) = (\<not>\<^sub>r (\<not>\<^sub>r P) ;; true\<^sub>r)"

expr_constructor RC1

definition RC :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "RC = RC1 \<circ> RR"

expr_constructor RC

lemma RC_intro: "\<lbrakk> P is RR; ((\<not>\<^sub>r (\<not>\<^sub>r P) ;; true\<^sub>r) = P) \<rbrakk> \<Longrightarrow> P is RC"
  by (simp add: Healthy_def RC1_def RC_def)

lemma RC_intro': "\<lbrakk> P is RR; P is RC1 \<rbrakk> \<Longrightarrow> P is RC"
  by (simp add: Healthy_def RC1_def RC_def)
lemma RC1_idem: "RC1(RC1(P)) = RC1(P)"
  by (pred_auto, (blast intro: dual_order.trans)+)

lemma RC1_mono: "P \<sqsubseteq> Q \<Longrightarrow> RC1(P) \<sqsubseteq> RC1(Q)"
  by (pred_auto, blast)

lemma RC1_prop:
  assumes "P is RC1"
  shows "(\<not>\<^sub>r P) ;; R1 true = (\<not>\<^sub>r P)"
proof -
  have "(\<not>\<^sub>r P) = (\<not>\<^sub>r (RC1 P))"
    by (simp add: Healthy_if assms)
  also have "... = (\<not>\<^sub>r P) ;; R1 true"
    by (simp add: RC1_def rpred closure)
  finally show ?thesis ..
qed

lemma R2_RC: "R2 (RC P) = RC P"
proof -
  have "\<not>\<^sub>r RR P is RR"
    by (metis (no_types) Healthy_Idempotent RR_Idempotent RR_rea_not)
  then show ?thesis
    by (metis (no_types) Healthy_def' R1_R2c_seqr_distribute R2_R2c_def RC1_def RC_def RR_implies_R1 RR_implies_R2c comp_apply rea_not_R2_closed rea_true_R1 rea_true_R2c)
qed

lemma RC_R2_def: "RC = RC1 \<circ> RR"
  by (auto simp add: RC_def fun_eq_iff R1_R2c_commute[THEN sym] R1_R2c_is_R2)

lemma RC_implies_R2: "P is RC \<Longrightarrow> P is R2"
  by (metis Healthy_def' R2_RC)

lemma RC_ex_ok_wait: "(\<Sqinter> k k' w w'. (RC P)\<lbrakk>k,k',w,w'/ok\<^sup><,ok\<^sup>>,wait\<^sup><,wait\<^sup>>\<rbrakk>) = RC P"
  by pred_auto

text \<open> An important property of reactive conditions is they are monotonic with respect to the trace.
  That is, $P$ with a shorter trace is refined by $P$ with a longer trace. \<close>

lemma RC_prefix_refine:
  assumes "P is RC" "s \<le> t"
  shows "P\<lbrakk>0,\<guillemotleft>s\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<sqsubseteq> P\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>"
proof -
  from assms(2) have "(RC P)\<lbrakk>0,\<guillemotleft>s\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<sqsubseteq> (RC P)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>"
    apply (pred_auto)
    using dual_order.trans apply blast
    done
  thus ?thesis
    by (simp only: assms(1) Healthy_if)
qed

text \<open> The @{term RC} healthy relations can also be defined in terms of prefix closure,
  which is characterised by the healthiness condition below. \<close>

definition RC2 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "RC2(P) = R1(P ;; (tr\<^sup>> \<le> tr\<^sup><)\<^sub>e)"

expr_constructor RC2

lemma RC2_RR_commute:
  "RC2(RR(P)) = RR(RC2(P))"
  apply (pred_auto)
  using minus_cancel_le apply blast
  apply (metis diff_add_cancel_left' le_add trace_class.add_diff_cancel_left trace_class.add_left_mono)
  done

text \<open> Intuitive meaning of @{term RC2} \<close>

lemma RC2_form_1:
  assumes "P is RR"
  shows "RC2(P) = (\<Sqinter> tr\<^sub>0 :: 'a list. (\<Sqinter> v\<^sub>0. P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>,\<guillemotleft>v\<^sub>0\<guillemotright>/tr\<^sup>>,\<^bold>v\<^sub>R\<^sup>>\<rbrakk>) \<and> (tr\<^sup>> \<le> \<guillemotleft>tr\<^sub>0\<guillemotright> \<and> tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)"
proof -
  have "RC2(RR(P)) = (\<Sqinter> tr\<^sub>0 :: 'a list. (\<Sqinter> v\<^sub>0. (RR P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>,\<guillemotleft>v\<^sub>0\<guillemotright>/tr\<^sup>>,\<^bold>v\<^sub>R\<^sup>>\<rbrakk>) \<and> (tr\<^sup>> \<le> \<guillemotleft>tr\<^sub>0\<guillemotright> \<and> tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)"
    by(pred_auto; blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma RC2_form_2:
  assumes "P is RR"
    shows "RC2(P) = (\<Sqinter> t\<^sub>0 t\<^sub>1. (\<Sqinter> v\<^sub>0. P\<lbrakk>0,\<guillemotleft>t\<^sub>1\<guillemotright>,\<guillemotleft>v\<^sub>0\<guillemotright>/tr\<^sup><,tr\<^sup>>,\<^bold>v\<^sub>R\<^sup>>\<rbrakk>) \<and> (\<guillemotleft>t\<^sub>0\<guillemotright> \<le> \<guillemotleft>t\<^sub>1\<guillemotright> \<and> tr\<^sup>> = tr\<^sup>< + \<guillemotleft>t\<^sub>0\<guillemotright>)\<^sub>e)"
proof -
  have "RC2(RR(P)) = (\<Sqinter> t\<^sub>0 t\<^sub>1. (\<Sqinter> v\<^sub>0. (RR P)\<lbrakk>0,\<guillemotleft>t\<^sub>1\<guillemotright>,\<guillemotleft>v\<^sub>0\<guillemotright>/tr\<^sup><,tr\<^sup>>,\<^bold>v\<^sub>R\<^sup>>\<rbrakk>) \<and> (\<guillemotleft>t\<^sub>0\<guillemotright> \<le> \<guillemotleft>t\<^sub>1\<guillemotright> \<and> tr\<^sup>> = tr\<^sup>< + \<guillemotleft>t\<^sub>0\<guillemotright>)\<^sub>e)"
    apply pred_auto
    apply (metis diff_add_cancel_left' trace_class.add_le_imp_le_left)
    apply (metis le_add trace_class.add_diff_cancel_left trace_class.add_left_mono)
    done
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

text \<open> Every reactive condition is prefix closed \<close>

lemma RC_prefix_closed:
  assumes "P is RC"
  shows "P is RC2"
proof -
  have "RC2(RC(P)) = RC(P)"
    by pred_auto
  thus ?thesis
    by (metis Healthy_def assms)
qed

lemma RC2_RR_is_RC1:
  assumes "P is RR" "P is RC2"
  shows "P is RC1"
proof -
  have "RC1(RC2(RR(P))) = RC2(RR(P))"
    apply pred_auto using dual_order.trans by blast
  thus ?thesis
    by (metis Healthy_def assms(1) assms(2))
qed

text \<open> @{term RC} closure can be demonstrated in terms of prefix closure. \<close>

lemma RC_intro_prefix_closed:
  assumes "P is RR" "P is RC2"
  shows "P is RC"
  by (simp add: RC2_RR_is_RC1 RC_intro' assms)

subsection \<open> Closure laws \<close>

lemma RC_implies_RR [closure]:
  assumes "P is RC"
  shows "P is RR"
  by (metis (no_types, lifting) Healthy_Idempotent Healthy_if Healthy_intro RC2_RR_commute RC2_RR_is_RC1 RC_R2_def RC_prefix_closed RR_Idempotent assms comp_def)
(*  by (metis Healthy_def RC_ex_ok_wait RC_implies_R2 RR_def assms) *)

lemma RC_implies_RC1: "P is RC \<Longrightarrow> P is RC1"
  by (metis Healthy_def RC_R2_def RC_implies_RR comp_eq_dest_lhs)

lemma RC1_trace_ext_prefix:
  "out\<alpha> \<sharp> e \<Longrightarrow> RC1(\<not>\<^sub>r (tr\<^sup>< @ e \<le> tr\<^sup>>)\<^sub>e) = (\<not>\<^sub>r (tr\<^sup>< @ e \<le> tr\<^sup>>)\<^sub>e)"
  by (pred_auto, blast, metis (no_types, lifting) dual_order.trans)

lemma RC1_conj [rpred]: "RC1(P \<and> Q) = (RC1(P) \<and> RC1(Q))"
  by (pred_auto; blast)

lemma conj_RC1_closed [closure]:
  "\<lbrakk> P is RC1; Q is RC1 \<rbrakk> \<Longrightarrow> P \<and> Q is RC1"
  by (simp add: Healthy_def RC1_conj)

lemma disj_RC1_closed [closure]:
  assumes "P is RC1" "Q is RC1"
  shows "(P \<or> Q) is RC1"
proof -
  have 1:"RC1(RC1(P) \<or> RC1(Q)) = (RC1(P) \<or> RC1(Q))"
    apply pred_auto using dual_order.trans by blast+
  show ?thesis
    by (metis (no_types) Healthy_def 1 assms)
qed

lemma conj_RC_closed [closure]:
  assumes "P is RC" "Q is RC"
  shows "(P \<and> Q) is RC"
  by (metis Healthy_def RC_R2_def RC_implies_RR assms comp_apply conj_RC1_closed conj_RR)

lemma rea_true_RC [closure]: "true\<^sub>r is RC"
  by pred_auto

lemma false_RC [closure]: "false is RC"
  by pred_auto

lemma disj_RC_closed [closure]: "\<lbrakk> P is RC; Q is RC \<rbrakk> \<Longrightarrow> (P \<or> Q) is RC"
  by (metis Healthy_def RC_R2_def RC_implies_RR comp_apply disj_RC1_closed disj_RR)

lemma UINF_mem_RC1_closed [closure]:
  assumes "\<And> i. P i is RC1"
  shows "(\<Sqinter> i\<in>A. P i) is RC1"
proof -
  have 1:"RC1(\<Sqinter> i\<in>A. RC1(P i)) = (\<Sqinter> i\<in>A. RC1(P i))"
    by (pred_auto, meson order.trans)
  show ?thesis
    by (metis (mono_tags, lifting) "1" Healthy_def SUP_cong assms)
qed

lemma UINF_mem_RC_closed [closure]:
  assumes "\<And> i. P i is RC"
  shows "(\<Sqinter> i\<in>A. P i) is RC"
proof -
  have "RC(\<Sqinter> i\<in>A. P i) = (RC1 \<circ> RR)(\<Sqinter> i\<in>A. P i)"
    by (simp add: RC_def)
  also have "... = RC1(\<Sqinter> i\<in>A. RR(P i))"
    by (pred_auto; blast)
  also have "... = RC1(\<Sqinter> i\<in>A. RC1(P i))"
    by (simp add: Healthy_if RC_implies_RR RC_implies_RC1 assms)
  also have "... = (\<Sqinter> i\<in>A. RC1(P i))"
    by (pred_auto, meson order.trans)
  also have "... = (\<Sqinter> i\<in>A. P i)"
    by (simp add: Healthy_if RC_implies_RC1 assms)
  finally show ?thesis
    by (simp add: Healthy_def)
qed

lemma UINF_ind_RC_closed [closure]:
  assumes "\<And> i. P i is RC"
  shows "(\<Sqinter> i. P i) is RC"
  using assms by (rule closure)

lemma USUP_mem_RC1_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RC1" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A. P i) is RC1"
proof -
  have "RC1(\<Squnion> i\<in>A. P i) = RC1(\<Squnion> i\<in>A. RC1(P i))"
    by (simp add: Healthy_if assms(1))
  also from assms(2) have "... = (\<Squnion> i\<in>A. RC1(P i))"
    apply pred_auto
    using order_trans order_refl by blast+
  also have "... = (\<Squnion> i\<in>A. P i)"
    by (simp add: Healthy_if assms(1))
  finally show ?thesis
    using Healthy_def by blast
qed

lemma USUP_mem_RC_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RC" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A. P i) is RC"
  by (rule RC_intro', simp_all add: closure assms RC_implies_RC1)

lemma USUP_ind_RC_closed [closure]:
  "\<lbrakk> \<And> i. P i is RC \<rbrakk> \<Longrightarrow> (\<Squnion> i. P i) is RC"
  by (metis UNIV_not_empty USUP_mem_RC_closed)

(* TODO: rebase proof on RC1_trace_ext_prefix *)
lemma neg_trace_ext_prefix_RC [closure]:
  "\<lbrakk> $tr\<^sup>< \<sharp> e; $ok\<^sup>< \<sharp> e; $wait\<^sup>< \<sharp> e; out\<alpha> \<sharp> e \<rbrakk> \<Longrightarrow> \<not>\<^sub>r (tr\<^sup>< @ e \<le> tr\<^sup>>)\<^sub>e is RC"
  apply (rule RC_intro)
  apply(simp add: closure)
  apply(pred_auto)
  apply (meson order_refl)
  apply (metis (no_types, opaque_lifting) order.trans)
  done
(*, metis RC1_def RC1_trace_ext_prefix) *)

lemma RC1_unrest:
  "\<lbrakk> mwb_lens x; x \<bowtie> tr \<rbrakk> \<Longrightarrow> $x\<^sup>> \<sharp> RC1(P)"
  by (simp add: RC1_def unrest)

lemma RC_unrest_dashed [unrest]:
  "\<lbrakk> P is RC; mwb_lens x; x \<bowtie> tr \<rbrakk> \<Longrightarrow> $x\<^sup>> \<sharp> P"
  by (metis Healthy_if RC1_unrest RC_implies_RC1)

lemma RC1_RR_closed [closure]: "P is RR \<Longrightarrow> RC1(P) is RR"
  by (simp add: RC1_def closure)

end


theory Ports
imports
  "HOL-Library.Word"
  "../Common/WordInterval_Lists"
  L4_Protocol_Flags
begin

section\<open>Ports (layer 4)\<close>
text\<open>E.g. source and destination ports for TCP/UDP\<close>

text\<open>list of (start, end) port ranges\<close>
type_synonym raw_ports = "(16 word \<times> 16 word) list"

fun ports_to_set :: "raw_ports \<Rightarrow> (16 word) set" where
  "ports_to_set [] = {}" |
  "ports_to_set ((s,e)#ps) = {s..e} \<union> ports_to_set ps"

lemma ports_to_set: "ports_to_set pts = \<Union> {{s..e} | s e . (s,e) \<in> set pts}"
  proof(induction pts)
  case Nil thus ?case by simp
  next
  case (Cons p pts) thus ?case by(cases p, simp, blast)
  qed

text\<open>We can reuse the wordinterval theory to reason about ports\<close>
lemma ports_to_set_wordinterval: "ports_to_set ps = wordinterval_to_set (l2wi ps)"
  by(induction ps rule: l2wi.induct) (auto)

text\<open>inverting a raw listing of ports\<close>
definition "raw_ports_invert" :: "raw_ports \<Rightarrow> raw_ports" where
  "raw_ports_invert ps = wi2l (wordinterval_invert (l2wi ps))"

lemma raw_ports_invert: "ports_to_set (raw_ports_invert ps) = - ports_to_set ps"
  by(auto simp add: raw_ports_invert_def l2wi_wi2l ports_to_set_wordinterval)

text\<open>A port always belongs to a protocol! We must not lose this information.
 You should never use @{typ raw_ports} directly\<close>
datatype ipt_l4_ports = L4Ports primitive_protocol raw_ports

end


theory trapez
imports segment
begin

(*Definition für Datentyp trapez. Durch 6 Punkte. nicht vertikale oben/unten und 2 vertikalen*)
typedef trapez = "{p::((point2d*point2d)*(point2d*point2d)*point2d*point2d). True}" by (auto)
(*Vereinfachung der Beweisführung für trapez*)

(*Trapez not Equiv.*)
definition trapezNotEq :: "trapez \<Rightarrow> trapez \<Rightarrow> bool" where "trapezNotEq A B \<equiv> A \<noteq> B"

(*identifiers for Trapez-parts*)
definition topT :: "trapez \<Rightarrow> (point2d\<times>point2d)" where  "topT T \<equiv> fst(Rep_trapez T)"
definition bottomT :: "trapez \<Rightarrow> (point2d\<times>point2d)" where "bottomT T \<equiv> fst(snd(Rep_trapez T))"
definition leftP :: "trapez \<Rightarrow> point2d" where "leftP T \<equiv> fst(snd(snd(Rep_trapez T)))"
definition rightP :: "trapez \<Rightarrow> point2d" where "rightP T \<equiv> snd(snd(snd(Rep_trapez T)))"

(*Lemmas zum reduzieren von trapez Termen*)
lemma topT [simp]: "topT (Abs_trapez (a, b, e, f)) = a" by (simp add: Abs_trapez_inverse topT_def)
lemma bottomT [simp]: "bottomT (Abs_trapez (a , b, e, f)) = b"
  by (auto simp add: Abs_trapez_inverse bottomT_def)
lemma leftP [simp]: "leftP (Abs_trapez (a, b, e, f)) = e"
  by (auto simp add: Abs_trapez_inverse leftP_def)
lemma rightP [simp]: " rightP (Abs_trapez (a, b, e, f)) = f"
  by (auto simp add: Abs_trapez_inverse rightP_def)

(*Anordnung der Trapez-Punkte auf der x-Koordinate*)
definition trapezPointsXOrder ::"trapez \<Rightarrow> bool"where
  "trapezPointsXOrder p \<equiv> leftFrom (leftP p) (rightP p) (*e links von f*)
  \<and> leftFrom (fst(topT p)) (snd(topT p)) (*a ist links von b*)
  \<and> leftFrom (fst(bottomT p)) (snd(bottomT p)) (*c ist links von d*)
  \<and> xCoord (leftP p) \<ge> xCoord (fst(topT p)) \<and> xCoord (leftP p) \<ge> xCoord (fst(bottomT p)) (*e \<ge> a \<and> c*)
  \<and> xCoord (rightP p) \<le> xCoord (snd(topT p)) \<and> xCoord (rightP p) \<le> xCoord (snd(bottomT p))(*f \<le> b \<and> d*)"

(*e < b \<and> d*)
lemma trapezHasOrderetPoints1: "trapezPointsXOrder p \<Longrightarrow>
  leftFrom (leftP p)(snd(topT p)) \<and> leftFrom (leftP p) (snd(bottomT p))"
  apply (simp add: leftFrom_def)
using leftFrom_def Orderings.xt1(8) trapezPointsXOrder_def by blast
(*f > a \<and> c*)
lemma trapezHasOrderetPoints2: "trapezPointsXOrder p \<Longrightarrow>
  leftFrom (fst(topT p)) (rightP p) \<and> leftFrom(fst(bottomT p)) (rightP p)"
  using leftFrom_def trapezPointsXOrder_def by auto
(*a < d*)
lemma trapezHasOrderetPoints3:"trapezPointsXOrder T \<Longrightarrow>leftFrom (fst(topT T)) (snd(bottomT T))"
  by (auto simp add: trapezPointsXOrder_def leftFrom_def)
(*b > c*)
lemma trapezHasOrderetPoints4:"trapezPointsXOrder T \<Longrightarrow>leftFrom (fst(bottomT T)) (snd(topT T))"
  by (auto simp add: trapezPointsXOrder_def leftFrom_def)

(*e ist zwischen ab und cd oder e=a oder e=c*)
definition trapezQuad:: "trapez \<Rightarrow> bool" where
  "trapezQuad p \<equiv>
  (rightTurn (fst(topT p)) (snd(topT p)) (leftP p) \<or> fst(topT p) = (leftP p)) (*e ist zwischen ab und cd*)
    \<and> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (leftP p) \<or> fst(bottomT p) = (leftP p))
    \<and> (rightTurn (fst(topT p)) (snd(topT p)) (rightP p) \<or> snd(topT p) = (rightP p))(* und f ist zwischen ab und cd*)
    \<and> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (rightP p) \<or> snd(bottomT p) = (rightP p))
    \<and> fst(topT p) \<noteq> fst(bottomT p) \<and> snd(topT p) \<noteq> snd(bottomT p) (*a\<noteq>c \<and> b\<noteq>d*)
    \<and> rightTurn (fst(topT p)) (snd(topT p)) (fst(bottomT p))(*a und b über c und d*)
    \<and> rightTurn (fst(topT p)) (snd(topT p)) (snd(bottomT p))"

lemma trapezTriangleVertex1: "trapezQuad p \<Longrightarrow>
  leftTurn (fst(bottomT p)) (snd(bottomT p)) (snd(topT p))
  \<and> leftTurn (fst(bottomT p)) (snd(bottomT p)) (fst(topT p))"
oops

(*eine der vertikalen Seiten des Trapezes ist ein Punkt*)
definition trapezTriangle :: "trapez \<Rightarrow> bool" where
   "trapezTriangle p \<equiv> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (fst(topT p)) (*a ist über cd*)
    \<and> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (leftP p) \<or> fst(bottomT p) = leftP p) (*e ist über cd*)
    \<and> (rightTurn (fst(topT p)) (snd(topT p)) (leftP p) \<or> fst(topT p) = leftP p) (*e ist unter a b*)
    \<and> snd(bottomT p) = snd(topT p) \<and> snd(bottomT p) = rightP p  (*und d=b=f*)
   )\<or>
   (fst(topT p) = fst(bottomT p) \<and> fst(bottomT p) = leftP p (*a=c=e*)
    \<and> leftTurn (fst(bottomT p)) (snd(bottomT p)) (snd(topT p)) (*b über c d*)
    \<and> (rightTurn (fst(topT p)) (snd(topT p)) (rightP p) \<or> snd(topT p) = rightP p) (*f ist unter a b*)
    \<and> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (rightP p) \<or> snd(bottomT p) = rightP p))" (*f ist über c d*)

lemma trapezTriangleVertex: "trapezTriangle p \<Longrightarrow>
  (leftTurn (fst(bottomT p)) (snd(bottomT p)) (snd(topT p)) \<and> fst(topT p) = fst(bottomT p))
  \<or> (leftTurn (fst(bottomT p)) (snd(bottomT p)) (fst(topT p)) \<and> snd(topT p) = snd(bottomT p))"
by (auto simp add: trapezTriangle_def)

(*Definition für Trapez ((a,b),(c,d),e,f)) top: (a,b), bottom:(c,d), leftP:e, rightP: f
  a=fst(fst p), b = snd(fst p), c=fst(fst(snd p)), d=snd(fst(snd p)), e=fst(snd(snd p)), f=snd(snd(snd p))*)
definition "isTrapez T \<equiv> trapezPointsXOrder T \<and> (trapezQuad T \<or> trapezTriangle T)"
definition trapezList :: "trapez list \<Rightarrow> bool" where
  "trapezList TM \<equiv> \<forall> T. T \<in> set TM \<longrightarrow> isTrapez T"
lemma trapezListSimp: "trapezList TM \<Longrightarrow> T \<in> set TM \<Longrightarrow> isTrapez T"
  by (simp add: trapezList_def)

(*linke Ecke ist links von der rechten Ecke*)
lemma leftPRigthFromRightP [simp] : "isTrapez T \<Longrightarrow> leftFrom (leftP T) (rightP T)"
  by (simp add: isTrapez_def trapezPointsXOrder_def)
(*Linke Ecken sind rechts von den rechten Ecken*)
lemma trapezNeighbour1 : "isTrapez T \<Longrightarrow> isTrapez Ts \<Longrightarrow> rightP T = leftP Ts \<Longrightarrow>
  leftFrom (rightP T) (rightP Ts)"
  by (cases T, simp)
lemma trapezNeighbour2 : "isTrapez T \<Longrightarrow> isTrapez Ts \<Longrightarrow> rightP T = leftP Ts \<Longrightarrow>
  leftFrom (leftP T) (leftP Ts)"
  by (metis leftPRigthFromRightP)

(*e < b \<and> d*)
lemma leftPRigthFromRightP1: "isTrapez p \<Longrightarrow> leftFrom (leftP p)(snd(topT p))
  \<and> leftFrom (leftP p) (snd(bottomT p))"
  apply (cases p, simp add: leftFrom_def)
by (simp add: isTrapez_def leftFrom_def trapezPointsXOrder_def)
(*f > a \<and> c*)
lemma trapezHasOrderetPoints6: "isTrapez p \<Longrightarrow>leftFrom (fst(topT p)) (rightP p)
  \<and> leftFrom(fst(bottomT p)) (rightP p)"
  by (metis isTrapez_def trapezHasOrderetPoints2)
(*a < d*)
lemma trapezHasOrderetPoints7:"isTrapez T \<Longrightarrow> leftFrom (fst(topT T)) (snd(bottomT T))"
  by (metis isTrapez_def trapezHasOrderetPoints3)
(*b > c*)
lemma trapezHasOrderetPoints8:"isTrapez T \<Longrightarrow> leftFrom (fst(bottomT T)) (snd(topT T))"
  by (metis isTrapez_def trapezHasOrderetPoints4)

(*topT und bottomT sind segmente*)
lemma topTSegment [simp]: "isTrapez T \<Longrightarrow> segment (fst(topT T)) (snd(topT T))"
  apply (cases T, subgoal_tac "xCoord (fst(topT T)) \<noteq> xCoord (snd(topT T))")
  apply (simp add: isTrapez_def)
by (metis isTrapez_def leftFrom_def not_less trapezHasOrderetPoints6 trapezPointsXOrder_def)
lemma bottomTSegment [simp]: "isTrapez T \<Longrightarrow> segment (fst(bottomT T)) (snd(bottomT T))"
  apply (cases T, subgoal_tac "xCoord (fst(bottomT T)) \<noteq> xCoord (snd(bottomT T))")
  apply (simp add: isTrapez_def)
by (metis  isTrapez_def leftFrom_def not_le trapezHasOrderetPoints2 trapezPointsXOrder_def)

(*Beweise über die Positionen der Ecken vom Trapez*)
(*engegengesetzte Ecken des Trapezes sind von einander ungleich*)
lemma trapezVertex: "isTrapez p \<Longrightarrow> snd(topT p) \<noteq> fst(bottomT p) \<and> snd(bottomT p) \<noteq> fst(topT p)"
  by (metis leftFromDest trapezHasOrderetPoints7 trapezHasOrderetPoints8)
(*mind. einer der Ecken von topT ist über bottomT*)
lemma topAboveBottom [intro]:"isTrapez T \<Longrightarrow>
  leftTurn (fst (bottomT T)) (snd (bottomT T)) (fst (topT T))
  \<or> leftTurn (fst (bottomT T)) (snd (bottomT T)) (snd (topT T))"
  apply (auto simp add: isTrapez_def)
oops
(*leftP ist über bottom T oder ist die linke Ecke von bottomT*)
lemma leftPPos[intro]:"isTrapez T \<Longrightarrow> leftTurn (fst(bottomT T)) (snd(bottomT T)) (leftP T)
  \<or> (fst(bottomT T) = leftP T)"
  apply (simp add: leftP_def bottomT_def del: leftRightTurn leftTurnRotate leftTurnRotate2,
    cases T, simp del: leftRightTurn leftTurnRotate leftTurnRotate2)
by (metis bottomT_def isTrapez_def leftP_def trapezQuad_def trapezTriangle_def)

lemma rightPPos [intro] : "isTrapez T \<Longrightarrow> rightTurn (fst(topT T)) (snd(topT T)) (rightP T)
  \<or> (snd(topT T) = rightP T)"
  apply (simp add: leftP_def bottomT_def del: leftRightTurn leftTurnRotate leftTurnRotate2,
   cases T, simp del: leftRightTurn leftTurnRotate leftTurnRotate2)
by(metis isTrapez_def rightTurnRotate trapezQuad_def trapezTriangle_def)

(*zwei Trapeze sind benachbart, wenn sie eine Ecke Teilen und bottomT oder topT gleich sind*)
definition neighbor :: "trapez \<Rightarrow> trapez \<Rightarrow> bool" where
  "isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow> neighbor T Tr \<equiv> rightP T = leftP Tr
  \<and> (topT T = topT Tr \<or> bottomT T = bottomT Tr)"
lemma neighborRightPSimp[simp]: "isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow> neighbor T Tr \<Longrightarrow>
  leftFrom (rightP T) (rightP Tr)"
  by (simp add: neighbor_def)
lemma neighborSam[dest]: "isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow> neighbor T T \<Longrightarrow> False"
  apply (simp add: neighbor_def, cases T, simp add: isTrapez_def)
  apply (simp add: trapezPointsXOrder_def)
by (metis leftFromDest)
lemma neighborNotSym[dest]:"isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow>neighbor T Tr \<Longrightarrow> neighbor Tr T \<Longrightarrow> False"
  apply (simp add: neighbor_def, cases T, simp add: isTrapez_def)
  apply (simp add: trapezPointsXOrder_def)
by (metis leftFromDest)

(*zwei Trapeze sind benachbart entland der Strecke PQ, wenn :
  - die linke Ecke eines Trapezes gleich der rechten Ecke des anderen Trapezes
  - topT gleich sind, falls PQ über rightPT bzw. bottomT gleich sind, falls PQ unter rightP.*)
definition neighborAlongSeg :: "trapez \<Rightarrow> trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "leftFrom P Q \<Longrightarrow> isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow>neighborAlongSeg T Ts P Q \<equiv> rightP T = leftP Ts \<and>
  ((rightTurn P Q (rightP T) \<and> topT T = topT Ts)
    \<or> (leftTurn P Q (rightP T) \<and> bottomT T = bottomT Ts))"
lemma neighborTrapezSame[dest]: "leftFrom P Q \<Longrightarrow> isTrapez T \<Longrightarrow> isTrapez Tr \<Longrightarrow>
  neighborAlongSeg T T P Q \<Longrightarrow> False"
  apply (auto simp add: neighborAlongSeg_def)
by (simp add: isTrapez_def leftFrom_def trapezPointsXOrder_def)+

(*ein Punkt P ist im Trapez T, wenn es auf den Kanten liegt, oder innerhalb des T*)
(*stimmt, weil von Vertikalen eingegrenzt*)
definition pointInTrapez :: "trapez \<Rightarrow> point2d \<Rightarrow> bool" where
  "isTrapez T \<Longrightarrow> pointInTrapez T P \<equiv> xCoord P \<le> xCoord (rightP T) \<and> xCoord P \<ge> xCoord (leftP T)
  \<and> signedArea (fst(bottomT T)) (snd(bottomT T)) P \<ge> 0 \<and> signedArea (fst(topT T)) (snd(topT T)) P \<le> 0"
lemma pointInTrapezSimp[simp]: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow> xCoord (rightP T) \<ge> xCoord P"
  by(simp add: pointInTrapez_def)
(*Punkt ist im Trapez, aber nicht auf den Kanten*)
definition pointInTrapezInner :: "trapez \<Rightarrow> point2d \<Rightarrow> bool" where
  "isTrapez T \<Longrightarrow> pointInTrapezInner T P \<equiv> xCoord P \<le> xCoord (rightP T) \<and> xCoord P \<ge> xCoord (leftP T)
  \<and> leftTurn (fst(bottomT T)) (snd(bottomT T)) P  \<and> rightTurn (fst(topT T)) (snd(topT T)) P
  \<and> P \<noteq> rightP T \<and> P \<noteq> leftP T"
lemma InnerToPointInTrapez[simp]: "isTrapez T \<Longrightarrow> pointInTrapezInner T P \<Longrightarrow> pointInTrapez T P"
  apply (auto simp add: pointInTrapez_def pointInTrapezInner_def)
  using rightTurn_def apply auto[1] using rightTurn_def apply auto[1]
done

lemma isNotInTrapez[dest]: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow>
  leftTurn (fst (topT T)) (snd (topT T)) P \<Longrightarrow> False"
by (meson leftTurn_def not_le pointInTrapez_def)
lemma isNotInTrapez1[dest]: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow>
  rightTurn (fst (bottomT T)) (snd (bottomT T)) P \<Longrightarrow> False"
by (meson rightTurn_def not_le pointInTrapez_def)

(*definition trapezSegmentIntersect :: "trapez \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "trapezSegmentIntersect T P Q \<equiv> intersect (fst (topT T)) (snd (topT T)) P Q
    \<or> intersect (fst (bottomT T)) (snd (bottomT T)) P Q \<or> "*)

(*********rBox. 4 Eckige Box um pointListe herum. First Trapez*)
(*Definition wann ist R eine rechteckige Box um PL herum*)
(*lassen sich die 3 pointInTrapez definitionen vereinheitlichen?*)
definition pointInRBox :: "trapez \<Rightarrow> point2d \<Rightarrow> bool" where
  "isTrapez R \<Longrightarrow> pointInRBox R P \<equiv> leftFrom P (rightP R) \<and> (leftFrom (leftP R) P)
  \<and> leftTurn (fst(bottomT R)) (snd(bottomT R)) P \<and> (rightTurn (fst(topT R)) (snd(topT R)) P)"
definition rBoxTrapezS :: "point2d list \<Rightarrow> trapez \<Rightarrow> bool" where
  "rBoxTrapezS PL R \<equiv> (\<forall> a \<in> set PL. pointInRBox R a) \<and> isTrapez R"
lemma rBoxTrapezSSimp[simp]: "isTrapez R \<Longrightarrow> rBoxTrapezS [a] R = pointInRBox R a"
  by (auto simp add: rBoxTrapezS_def)
lemma rBoxTrapezSConcat: "rBoxTrapezS (concat PL) R \<Longrightarrow> i < length PL \<Longrightarrow> rBoxTrapezS (PL!i) R"
  apply (subgoal_tac "\<forall> a \<in> set (concat PL). pointInRBox R a")
by (auto simp add: rBoxTrapezS_def)
lemma rBoxTrapezSConcatEq : "PL \<noteq> [] \<Longrightarrow>
  rBoxTrapezS (concat PL) R = (\<forall> i < length PL. rBoxTrapezS (PL!i) R)"
  apply (auto simp add: rBoxTrapezSConcat)
  apply (subgoal_tac "(\<forall> a \<in> set (concat PL). pointInRBox R a)")
  apply (auto simp add: rBoxTrapezS_def)
by (smt UN_iff in_set_conv_nth set_concat)+

(*erstellung neuer Trapeze*)
lemma newTrapez[simp]: "isTrapez oT \<Longrightarrow> pointInRBox oT P \<Longrightarrow>
  isTrapez (Abs_trapez (topT oT, bottomT oT, leftP oT, P))"
  apply (cases oT, simp add: isTrapez_def, rule conjI)
  using isTrapez_def apply auto[1]
  apply (simp add: trapezPointsXOrder_def pointInRBox_def)
  using leftFrom_def apply auto[1]
  apply (simp add: pointInRBox_def leftFrom_def  trapezPointsXOrder_def)
  apply (erule conjE)
  apply (erule disjE, rule disjI1)
  apply (simp add: isTrapez_def pointInRBox_def trapezQuad_def)
  apply (subst (asm) trapezTriangle_def, simp)
  apply (erule disjE, erule conjE, simp)+
  apply (erule conjE, erule disjE)+ apply (erule conjE, simp)+
oops
lemma newTrapez1[simp]: "isTrapez oT \<Longrightarrow> pointInRBox oT P \<Longrightarrow>
  isTrapez (Abs_trapez (topT oT, bottomT oT, P, rightP oT))"
oops

(*(*jeder Punkt der auf der xCoordinate von rightP steht und von topT und bottomT eingegrenzt wird*)
definition pointOnLeftT :: "trapez \<Rightarrow> point2d \<Rightarrow> bool" where
  "pointOnLeftT T p \<equiv> rightTurn (fst(topT T)) (snd(topT T)) p
    \<and> leftTurn (fst(bottomT T)) (snd(bottomT T)) p \<and> xCoord (leftP T) = xCoord p"
definition pointOnRightT :: "trapez \<Rightarrow> point2d \<Rightarrow> bool" where
  "pointOnRightT T p \<equiv> rightTurn (fst(topT T)) (snd(topT T)) p
    \<and> leftTurn (fst(bottomT T)) (snd(bottomT T)) p \<and> xCoord (rightP T) = xCoord p"
lemma pointNotOnLeftRightT[dest]: "pointOnLeftT T p \<Longrightarrow> pointOnRightT T p \<Longrightarrow> False"
  apply (simp add: pointOnLeftT_def pointOnRightT_def isTrapez_def trapezPointsXOrder_def)
by (metis leftFrom_def leftPRigthFromRightP1 less_irrefl)*)

end