(*  Title:      regular/HMLSL_Regular.thy
    Author:     Sven Linker

Defines HMLSL with regular sensors for cars.
*)
section\<open>HMLSL for Regular Sensors\<close>
text \<open>
Within this section, we instantiate HMLSL for cars with
regular sensors.
\<close>

theory HMLSL_Regular
  imports "../HMLSL" Regular_Sensors
begin

locale hmlsl_regular = regular_sensors + restriction
begin
interpretation hmlsl : hmlsl "regular :: cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
proof unfold_locales
  fix e ts c
  show " 0 < regular e ts c"
    by (metis less_add_same_cancel2 less_trans regular_def
        traffic.psGeZero traffic.sdGeZero)
qed

notation hmlsl.re ("re'(_')")
notation hmlsl.cl("cl'(_')")
notation hmlsl.len ("len")

text \<open>
The spatial atoms are dependent of the perspective of the view,
hence we cannot prove similar lemmas as for perfect sensors.

However, we can still prove
lemmas corresponding to the activity and stability rules of the
proof system for MLSL \cite{Linker2015a}.

Similar to the situation with perfect sensors, needed to instantiate the
sensor function, to ensure that the perceived length does not change
during spatial transitions.
\<close>

lemma backwards_res_act:
  "(ts \<^bold>\<midarrow>r(c) \<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> re(c)) \<longrightarrow> (ts,v \<Turnstile> re(c) \<^bold>\<or> cl(c))"
proof
  assume assm:"(ts \<^bold>\<midarrow>r(c) \<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> re(c))"
  from assm have len_eq:"len v ts c = len v ts' c"
    using create_reservation_length_stable by blast
  have "res ts c \<sqsubseteq> res ts' c" using assm traffic.create_res_subseteq1
    by auto
  hence restr_subs_res:"restrict v (res ts) c \<sqsubseteq> restrict v (res ts') c"
    using assm restriction.restrict_view
    using create_reservation_restrict_union by auto
  have "clm ts c \<sqsubseteq> res ts' c" using assm traffic.create_res_subseteq2
    using assm restriction.restrict_view  by auto
  hence restr_subs_clm:"restrict v (clm ts) c \<sqsubseteq> restrict v (res ts') c"
    using assm restriction.restrict_view
    using restriction.create_reservation_restrict_union by auto
  have "restrict v (res ts) c = \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>" by simp
  then show " ts,v \<Turnstile> (re(c) \<^bold>\<or> cl(c))"
  proof
    assume restr_res_nonempty:"restrict v (res ts) c \<noteq> \<emptyset>"
    hence restrict_one:"|restrict v (res ts) c | = 1"
      using nat_int.card_non_empty_geq_one nat_int.card_subset_le dual_order.antisym
        restr_subs_res assm
      using local.hmlsl.re_def local.hmlsl.satisfies_def by fastforce
    have "restrict v (res ts ) c \<sqsubseteq> lan v" using restr_subs_res assm
      by (simp add: restriction.restrict_view)
    hence "restrict v (res ts)c = lan v" using restriction.restrict_eq_lan_subs
        restrict_one assm
      using local.hmlsl.re_def local.hmlsl.satisfies_def by auto
    then show ?thesis using assm len_eq
      by (simp add: local.hmlsl.re_def local.hmlsl.satisfies_def)
  next
    assume restr_res_empty:"restrict v (res ts) c = \<emptyset>"
    then have  clm_non_empty: "restrict v (clm ts) c \<noteq> \<emptyset>"
      using HMLSL.hmlsl.re_def assm local.hmlsl.re_def local.hmlsl.satisfies_def nat_int.card_empty_zero restriction.create_reservation_restrict_union by auto
    then  have restrict_one:"|restrict v (clm ts) c | = 1"
      using nat_int.card_non_empty_geq_one nat_int.card_subset_le dual_order.antisym
        restr_subs_clm assm
      using restriction.restriction_clm_leq_one by fastforce
    have "restrict v (clm ts ) c \<sqsubseteq> lan v" using restr_subs_clm assm
      using restriction.restrict_view by auto
    hence "restrict v (clm ts)c = lan v" using restriction.restrict_eq_lan_subs
        restrict_one assm
      using local.hmlsl.re_def local.hmlsl.satisfies_def by auto
    then show ?thesis using assm len_eq
      by (simp add: local.hmlsl.cl_def local.hmlsl.re_def local.hmlsl.satisfies_def)
  qed
qed

lemma backwards_res_act_somewhere:
  "(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> \<^bold>\<langle>re(c)\<^bold>\<rangle>) \<longrightarrow> (ts,v \<Turnstile>\<^bold>\<langle> re(c) \<^bold>\<or> cl(c)\<^bold>\<rangle> )"
proof
  assume a:"(ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow> ts') \<and> (ts',v \<Turnstile> \<^bold>\<langle>re(c)\<^bold>\<rangle>)"
  then obtain v' where "(ts',v' \<Turnstile> re(c)) \<and> v' \<le> v"
    using local.hmlsl.hchop_def local.hmlsl.satisfies_def local.hmlsl.vchop_def hmlsl.somewhere_leq
    by (metis (no_types, lifting))
  then have "ts,v' \<Turnstile> re(c) \<^bold>\<or> cl(c)" using backwards_res_act a by blast
  then show "ts,v \<Turnstile>\<^bold>\<langle> re(c) \<^bold>\<or> cl(c)\<^bold>\<rangle>"
  using backwards_res_act hmlsl.satisfies_def hmlsl.somewhere_leq
  using \<open>(ts' , v' \<Turnstile> re(c)) \<and> v' \<le> v\<close> by auto
qed

lemma backwards_res_stab:
  "(ts \<^bold>\<midarrow>r(d) \<^bold>\<rightarrow> ts') \<and>  (d \<noteq>c) \<and> (ts',v \<Turnstile> re(c)) \<longrightarrow> (ts,v \<Turnstile> re(c))"
  using regular_sensors.create_reservation_length_stable restrict_def'
    traffic.create_res_subseteq1_neq
  using local.hmlsl.re_def local.hmlsl.satisfies_def by auto

text\<open>
We now proceed to prove the \emph{reservation lemma}, which was
crucial in the manual safety proof \cite {Hilscher2011}.
\<close>
lemma reservation1: "\<Turnstile>(re(c) \<^bold>\<or> cl(c)) \<^bold>\<rightarrow> \<^bold>\<box>r(c) re(c)"
proof -
  { fix ts v ts'
  assume assm:"ts,v \<Turnstile>re(c) \<^bold>\<or> cl(c)" and ts'_def:"ts \<^bold>\<midarrow>r(c)\<^bold>\<rightarrow>ts'"
  from assm have  "re(c) ts' v" unfolding hmlsl.satisfies_def
  proof
    assume re:  "re(c) ts v"
    then show ?thesis
      using local.hmlsl.re_def regular_sensors.create_reservation_length_stable restrict_view restriction.create_reservation_restrict_union sup.absorb_iff1 ts'_def by fastforce
  next
    assume cl:"cl(c) ts v"
    then show ?thesis
      by (metis (no_types, lifting) dual_order.antisym local.hmlsl.cl_def local.hmlsl.re_def regular_sensors.create_reservation_length_stable restrict_view restriction.create_reservation_restrict_union sup_ge2 ts'_def)
  qed
  }
  then show ?thesis using hmlsl.satisfies_def hmlsl.valid_def  sorry
qed

lemma reservation2: "\<Turnstile>(\<^bold>\<box>r(c) re(c)) \<^bold>\<rightarrow> (re(c) \<^bold>\<or> cl(c))"
  using backwards_res_act traffic.always_create_res
  by (metis (no_types, lifting) local.hmlsl.satisfies_def local.hmlsl.valid_def)

lemma reservation:"\<Turnstile>(\<^bold>\<box>r(c) re(c)) \<^bold>\<leftrightarrow> (re(c) \<^bold>\<or> cl(c))"
  using reservation1 reservation2 local.hmlsl.valid_def hmlsl.satisfies_def sorry
end
end


(*  Title:      ZF/Resid/Substitution.thy
    Author:     Ole Rasmussen, University of Cambridge
*)

theory Substitution imports Redex begin

(** The clumsy _aux functions are required because other arguments vary
    in the recursive calls ***)

consts
  lift_aux      :: "i=>i"
primrec
  "lift_aux(Var(i)) = (\<lambda>k \<in> nat. if i<k then Var(i) else Var(succ(i)))"

  "lift_aux(Fun(t)) = (\<lambda>k \<in> nat. Fun(lift_aux(t) ` succ(k)))"

  "lift_aux(App(b,f,a)) = (\<lambda>k \<in> nat. App(b, lift_aux(f)`k, lift_aux(a)`k))"

definition
  lift_rec      :: "[i,i]=> i"  where
    "lift_rec(r,k) == lift_aux(r)`k"

abbreviation
  lift :: "i=>i" where
  "lift(r) == lift_rec(r,0)"

consts
  subst_aux     :: "i=>i"
primrec
  "subst_aux(Var(i)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. if k<i then Var(i #- 1)
                                else if k=i then r else Var(i))"
  "subst_aux(Fun(t)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. Fun(subst_aux(t) ` lift(r) ` succ(k)))"

  "subst_aux(App(b,f,a)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. App(b, subst_aux(f)`r`k, subst_aux(a)`r`k))"

definition
  subst_rec     :: "[i,i,i]=> i"        (**NOTE THE ARGUMENT ORDER BELOW**)  where
    "subst_rec(u,r,k) == subst_aux(r)`u`k"

abbreviation
  subst :: "[i,i]=>i"  (infixl \<open>'/\<close> 70)  where
  "u/v == subst_rec(u,v,0)"

(* ------------------------------------------------------------------------- *)
(*   Arithmetic extensions                                                   *)
(* ------------------------------------------------------------------------- *)

lemma gt_not_eq: "p < n ==> n\<noteq>p"
by blast

lemma succ_pred [rule_format, simp]: "j \<in> nat ==> i < j \<longrightarrow> succ(j #- 1) = j"
by (induct_tac "j", auto)

lemma lt_pred: "[|succ(x)<n; n \<in> nat|] ==> x < n #- 1 "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

lemma gt_pred: "[|n < succ(x); p<n; n \<in> nat|] ==> n #- 1 < x "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

declare not_lt_iff_le [simp] if_P [simp] if_not_P [simp]

(* ------------------------------------------------------------------------- *)
(*     lift_rec equality rules                                               *)
(* ------------------------------------------------------------------------- *)
lemma lift_rec_Var:
     "n \<in> nat ==> lift_rec(Var(i),n) = (if i<n then Var(i) else Var(succ(i)))"
by (simp add: lift_rec_def)

lemma lift_rec_le [simp]:
     "[|i \<in> nat; k\<le>i|] ==> lift_rec(Var(i),k) = Var(succ(i))"
by (simp add: lift_rec_def le_in_nat)

lemma lift_rec_gt [simp]: "[| k \<in> nat; i<k |] ==> lift_rec(Var(i),k) = Var(i)"
by (simp add: lift_rec_def)

lemma lift_rec_Fun [simp]:
     "k \<in> nat ==> lift_rec(Fun(t),k) = Fun(lift_rec(t,succ(k)))"
by (simp add: lift_rec_def)

lemma lift_rec_App [simp]:
     "k \<in> nat ==> lift_rec(App(b,f,a),k) = App(b,lift_rec(f,k),lift_rec(a,k))"
by (simp add: lift_rec_def)

(* ------------------------------------------------------------------------- *)
(*    substitution quality rules                                             *)
(* ------------------------------------------------------------------------- *)

lemma subst_Var:
     "[|k \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,Var(i),k) =
          (if k<i then Var(i #- 1) else if k=i then u else Var(i))"
by (simp add: subst_rec_def gt_not_eq leI)

lemma subst_eq [simp]:
     "[|n \<in> nat; u \<in> redexes|] ==> subst_rec(u,Var(n),n) = u"
by (simp add: subst_rec_def)

lemma subst_gt [simp]:
     "[|u \<in> redexes; p \<in> nat; p<n|] ==> subst_rec(u,Var(n),p) = Var(n #- 1)"
by (simp add: subst_rec_def)

lemma subst_lt [simp]:
     "[|u \<in> redexes; p \<in> nat; n<p|] ==> subst_rec(u,Var(n),p) = Var(n)"
by (simp add: subst_rec_def gt_not_eq leI lt_nat_in_nat)

lemma subst_Fun [simp]:
     "[|p \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,Fun(t),p) = Fun(subst_rec(lift(u),t,succ(p))) "
by (simp add: subst_rec_def)

lemma subst_App [simp]:
     "[|p \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,App(b,f,a),p) = App(b,subst_rec(u,f,p),subst_rec(u,a,p))"
by (simp add: subst_rec_def)

lemma lift_rec_type [rule_format, simp]:
     "u \<in> redexes ==> \<forall>k \<in> nat. lift_rec(u,k) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: lift_rec_Var lift_rec_Fun lift_rec_App)
done

lemma subst_type [rule_format, simp]:
     "v \<in> redexes ==>  \<forall>n \<in> nat. \<forall>u \<in> redexes. subst_rec(u,v,n) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: subst_Var lift_rec_type)
done

(* ------------------------------------------------------------------------- *)
(*    lift and  substitution proofs                                          *)
(* ------------------------------------------------------------------------- *)

(*The i\<in>nat is redundant*)
lemma lift_lift_rec [rule_format]:
     "u \<in> redexes
      ==> \<forall>n \<in> nat. \<forall>i \<in> nat. i\<le>n \<longrightarrow>
           (lift_rec(lift_rec(u,i),succ(n)) = lift_rec(lift_rec(u,n),i))"
apply (erule redexes.induct, auto)
apply (case_tac "n < i")
apply (frule lt_trans2, assumption)
apply (simp_all add: lift_rec_Var leI)
done

lemma lift_lift:
     "[|u \<in> redexes; n \<in> nat|]
      ==> lift_rec(lift(u),succ(n)) = lift(lift_rec(u,n))"
by (simp add: lift_lift_rec)

lemma lt_not_m1_lt: "\<lbrakk>m < n; n \<in> nat; m \<in> nat\<rbrakk>\<Longrightarrow> ~ n #- 1 < m"
by (erule natE, auto)

lemma lift_rec_subst_rec [rule_format]:
     "v \<in> redexes ==>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. n\<le>m\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,succ(m)),n)"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
 apply (frule_tac j = n' in lt_trans2, assumption)
 apply (simp add: leI, simp)
apply (erule_tac j=n in leE)
apply (auto simp add: lift_rec_Var subst_Var leI lt_not_m1_lt)
done

lemma lift_subst:
     "[|v \<in> redexes; u \<in> redexes; n \<in> nat|]
      ==> lift_rec(u/v,n) = lift_rec(u,n)/lift_rec(v,succ(n))"
by (simp add: lift_rec_subst_rec)

lemma lift_rec_subst_rec_lt [rule_format]:
     "v \<in> redexes ==>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. m\<le>n\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,m),succ(n))"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
apply (case_tac "n < m")
apply (simp_all add: leI)
apply (erule_tac i=n' in leE)
apply (frule lt_trans1, assumption)
apply (simp_all add: succ_pred leI gt_pred)
done

lemma subst_rec_lift_rec [rule_format]:
     "u \<in> redexes ==>
        \<forall>n \<in> nat. \<forall>v \<in> redexes. subst_rec(v,lift_rec(u,n),n) = u"
apply (erule redexes.induct, auto)
apply (case_tac "n < na", auto)
done

lemma subst_rec_subst_rec [rule_format]:
     "v \<in> redexes ==>
        \<forall>m \<in> nat. \<forall>n \<in> nat. \<forall>u \<in> redexes. \<forall>w \<in> redexes. m\<le>n \<longrightarrow>
          subst_rec(subst_rec(w,u,n),subst_rec(lift_rec(w,m),v,succ(n)),m) =
          subst_rec(w,subst_rec(u,v,m),n)"
apply (erule redexes.induct)
apply (simp_all add: lift_lift [symmetric] lift_rec_subst_rec_lt, safe)
apply (rename_tac n' u w)
apply (case_tac "n \<le> succ(n') ")
 apply (erule_tac i = n in leE)
 apply (simp_all add: succ_pred subst_rec_lift_rec leI)
 apply (case_tac "n < m")
  apply (frule lt_trans2, assumption, simp add: gt_pred)
 apply simp
 apply (erule_tac j = n in leE, simp add: gt_pred)
 apply (simp add: subst_rec_lift_rec)
(*final case*)
apply (frule nat_into_Ord [THEN le_refl, THEN lt_trans], assumption)
apply (erule leE)
 apply (frule succ_leI [THEN lt_trans], assumption)
 apply (frule_tac i = m in nat_into_Ord [THEN le_refl, THEN lt_trans],
        assumption)
 apply (simp_all add: succ_pred lt_pred)
done

lemma substitution:
     "[|v \<in> redexes; u \<in> redexes; w \<in> redexes; n \<in> nat|]
      ==> subst_rec(w,u,n)/subst_rec(lift(w),v,succ(n)) = subst_rec(w,u/v,n)"
by (simp add: subst_rec_subst_rec)

(* ------------------------------------------------------------------------- *)
(*          Preservation lemmas                                              *)
(*          Substitution preserves comp and regular                          *)
(* ------------------------------------------------------------------------- *)

lemma lift_rec_preserve_comp [rule_format, simp]:
     "u \<sim> v ==> \<forall>m \<in> nat. lift_rec(u,m) \<sim> lift_rec(v,m)"
by (erule Scomp.induct, simp_all add: comp_refl)

lemma subst_rec_preserve_comp [rule_format, simp]:
     "u2 \<sim> v2 ==> \<forall>m \<in> nat. \<forall>u1 \<in> redexes. \<forall>v1 \<in> redexes.
                  u1 \<sim> v1\<longrightarrow> subst_rec(u1,u2,m) \<sim> subst_rec(v1,v2,m)"
by (erule Scomp.induct,
    simp_all add: subst_Var lift_rec_preserve_comp comp_refl)

lemma lift_rec_preserve_reg [simp]:
     "regular(u) ==> \<forall>m \<in> nat. regular(lift_rec(u,m))"
by (erule Sreg.induct, simp_all add: lift_rec_Var)

lemma subst_rec_preserve_reg [simp]:
     "regular(v) ==>
        \<forall>m \<in> nat. \<forall>u \<in> redexes. regular(u)\<longrightarrow>regular(subst_rec(u,v,m))"
by (erule Sreg.induct, simp_all add: subst_Var lift_rec_preserve_reg)

end


(*  Title:       Signed Hereditar(il)y (Finite) Multisets
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Signed Hereditar(il)y (Finite) Multisets\<close>

theory Signed_Hereditary_Multiset
imports Signed_Multiset Hereditary_Multiset
begin

subsection \<open>Type Definition\<close>

typedef zhmultiset = "UNIV :: hmultiset zmultiset set"
  morphisms zhmsetmset ZHMSet
  by simp

lemmas ZHMSet_inverse[simp] = ZHMSet_inverse[OF UNIV_I]
lemmas ZHMSet_inject[simp] = ZHMSet_inject[OF UNIV_I UNIV_I]

declare
  zhmsetmset_inverse [simp]
  zhmsetmset_inject [simp]

setup_lifting type_definition_zhmultiset

subsection \<open>Multiset Order\<close>

instantiation zhmultiset :: linorder
begin

lift_definition less_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> bool" is "(\<le>)" .

instance
  by (intro_classes; transfer) auto

end

lemmas ZHMSet_less[simp] = less_zhmultiset.abs_eq
lemmas ZHMSet_le[simp] = less_eq_zhmultiset.abs_eq
lemmas zhmsetmset_less[simp] = less_zhmultiset.rep_eq[symmetric]
lemmas zhmsetmset_le[simp] = less_eq_zhmultiset.rep_eq[symmetric]

subsection \<open>Embedding and Projections of Syntactic Ordinals\<close>

abbreviation zhmset_of :: "hmultiset \<Rightarrow> zhmultiset" where
  "zhmset_of M \<equiv> ZHMSet (zmset_of (hmsetmset M))"

lemma zhmset_of_inject[simp]: "zhmset_of M = zhmset_of N \<longleftrightarrow> M = N"
  by simp

lemma zhmset_of_less: "zhmset_of M < zhmset_of N \<longleftrightarrow> M < N"
  by (simp add: zmset_of_less)

lemma zhmset_of_le: "zhmset_of M \<le> zhmset_of N \<longleftrightarrow> M \<le> N"
  by (simp add: zmset_of_le)

abbreviation hmset_pos :: "zhmultiset \<Rightarrow> hmultiset" where
  "hmset_pos M \<equiv> HMSet (mset_pos (zhmsetmset M))"

abbreviation hmset_neg :: "zhmultiset \<Rightarrow> hmultiset" where
  "hmset_neg M \<equiv> HMSet (mset_neg (zhmsetmset M))"

subsection \<open>Disjoint Union and Difference\<close>

instantiation zhmultiset :: cancel_comm_monoid_add
begin

lift_definition zero_zhmultiset :: zhmultiset is "{#}\<^sub>z" .

lift_definition plus_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> zhmultiset" is
  "\<lambda>A B. A + B" .

lift_definition minus_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> zhmultiset" is
  "\<lambda>A B. A - B" .

lemmas ZHMSet_plus = plus_zhmultiset.abs_eq[symmetric]
lemmas ZHMSet_diff = minus_zhmultiset.abs_eq[symmetric]
lemmas zhmsetmset_plus = plus_zhmultiset.rep_eq
lemmas zhmsetmset_diff = minus_zhmultiset.rep_eq

lemma zhmset_of_plus: "zhmset_of (A + B) = zhmset_of A + zhmset_of B"
  by (simp add: hmsetmset_plus ZHMSet_plus zmset_of_plus)

lemma hmsetmset_0[simp]: "hmsetmset 0 = {#}"
  by (rule hmultiset.inject[THEN iffD1]) (simp add: zero_hmultiset_def)

instance
  by (intro_classes; transfer) (auto intro: mult.assoc add.commute)

end

lemma zhmset_of_0: "zhmset_of 0 = 0"
  by (simp add: zero_zhmultiset_def)

lemma hmset_pos_plus:
  "hmset_pos (A + B) = (hmset_pos A - hmset_neg B) + (hmset_pos B - hmset_neg A)"
  by (simp add: HMSet_diff HMSet_plus zhmsetmset_plus)

lemma hmset_neg_plus:
  "hmset_neg (A + B) = (hmset_neg A - hmset_pos B) + (hmset_neg B - hmset_pos A)"
  by (simp add: HMSet_diff HMSet_plus zhmsetmset_plus)

lemma zhmset_pos_neg_partition: "M = zhmset_of (hmset_pos M) - zhmset_of (hmset_neg M)"
  by (cases M, simp add: ZHMSet_diff[symmetric], rule mset_pos_neg_partition)

lemma zhmset_pos_as_neg: "zhmset_of (hmset_pos M) = zhmset_of (hmset_neg M) + M"
  using mset_pos_as_neg zhmsetmset_plus zhmsetmset_inject by fastforce

lemma zhmset_neg_as_pos: "zhmset_of (hmset_neg M) = zhmset_of (hmset_pos M) - M"
  using zhmsetmset_diff mset_neg_as_pos zhmsetmset_inject by fastforce

lemma hmset_pos_neg_dual:
  "hmset_pos a + hmset_pos b + (hmset_neg a - hmset_pos b) + (hmset_neg b - hmset_pos a) =
   hmset_neg a + hmset_neg b + (hmset_pos a - hmset_neg b) + (hmset_pos b - hmset_neg a)"
  by (simp add: HMSet_plus[symmetric] HMSet_diff[symmetric]) (rule mset_pos_neg_dual)

lemma zhmset_of_sum_list: "zhmset_of (sum_list Ms) = sum_list (map zhmset_of Ms)"
  by (induct Ms) (auto simp: zero_zhmultiset_def zhmset_of_plus)

lemma less_hmset_zhmsetE:
  assumes m_lt_n: "M < N"
  obtains A B C where "M = zhmset_of A + C" and "N = zhmset_of B + C" and "A < B"
  by (rule less_mset_zmsetE[OF m_lt_n[folded zhmsetmset_less]])
    (metis hmsetmset_less hmultiset.sel ZHMSet_plus zhmsetmset_inverse)

lemma less_eq_hmset_zhmsetE:
  assumes m_le_n: "M \<le> N"
  obtains A B C where "M = zhmset_of A + C" and "N = zhmset_of B + C" and "A \<le> B"
  by (rule less_eq_mset_zmsetE[OF m_le_n[folded zhmsetmset_le]])
    (metis hmsetmset_le hmultiset.sel ZHMSet_plus zhmsetmset_inverse)

instantiation zhmultiset :: ab_group_add
begin

lift_definition uminus_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset" is "\<lambda>A. - A" .

lemmas ZHMSet_uminus = uminus_zhmultiset.abs_eq[symmetric]
lemmas zhmsetmset_uminus = uminus_zhmultiset.rep_eq

instance
  by (intro_classes; transfer; simp)

end

subsection \<open>Infimum and Supremum\<close>

instance zhmultiset :: ordered_cancel_comm_monoid_add
  by (intro_classes; transfer) (auto simp: add_left_mono)

instance zhmultiset :: ordered_ab_group_add
  by (intro_classes; transfer; simp)

instantiation zhmultiset :: distrib_lattice
begin

definition inf_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> zhmultiset" where
  "inf_zhmultiset A B = (if A < B then A else B)"

definition sup_zhmultiset :: "zhmultiset \<Rightarrow> zhmultiset \<Rightarrow> zhmultiset" where
  "sup_zhmultiset A B = (if B > A then B else A)"

instance
  by intro_classes (auto simp: inf_zhmultiset_def sup_zhmultiset_def)

end

end


(*    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2021 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open> Ordered loops \<close>

theory OrderedLoop_ZF imports Loop_ZF Order_ZF

begin

text\<open> This theory file is about properties of loops (the algebraic structures introduced
  in IsarMathLib in the \<open>Loop_ZF\<close> theory) with an additional order relation that is in
  a way compatible with the loop's binary operation. The oldest reference I have found on the subject is
  \cite{Zelinski1948}. \<close>

subsection\<open>Definition and notation\<close>

text\<open> An ordered loop $(G,A)$ is a loop with a partial order relation r that is
  "translation invariant" with respect to the loop operation $A$.\<close>

text\<open> A triple $(G,A,r)$ is an ordered loop if $(G,A)$ is a loop and $r$ is a relation
  on $G$ (i.e. a subset of $G\times G$ with is a partial order and for all elements $x,y,z \in G$
  the condition $\langle x,y\rangle \in r$ is equivalent to both
  $\langle A\langle x,z\rangle, A\langle x,z\rangle\rangle \in r$ and
  $\langle A\langle z,x\rangle, A\langle z,x\rangle\rangle \in r$.
  This looks a bit awkward in the basic set theory notation, but using the additive notation
  for the group operation and $x\leq y$ to instead of $\langle x,y \rangle \in r$ this just means that
  $x\leq y$ if and only if $x+z\leq y+z$ and $x\leq y$ if and only if $z+x\leq z+y$. \<close>

definition
  "IsAnOrdLoop(L,A,r) \<equiv>
  IsAloop(L,A) \<and> r\<subseteq>L\<times>L \<and> IsPartOrder(L,r) \<and> (\<forall>x\<in>L. \<forall>y\<in>L. \<forall>z\<in>L.
  ((\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle> x,z\<rangle>,A`\<langle>y,z\<rangle>\<rangle> \<in> r) \<and> (\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle>z,x\<rangle>,A`\<langle>z,y\<rangle>\<rangle> \<in> r )))"

text\<open>We define the set of nonnegative elements  in the obvious way as $L^+ =\{x\in L: 0 \leq x\}$.\<close>

definition
  "Nonnegative(L,A,r) \<equiv> {x\<in>L. \<langle> TheNeutralElement(L,A),x\<rangle> \<in> r}"

text\<open>The \<open>PositiveSet(L,A,r)\<close> is a set similar to  \<open>Nonnegative(L,A,r)\<close>, but without the neutral element.\<close>

definition
  "PositiveSet(L,A,r) \<equiv>
  {x\<in>L. \<langle> TheNeutralElement(L,A),x\<rangle> \<in> r \<and> TheNeutralElement(L,A)\<noteq> x}"

text\<open> We will use the additive notation for ordered loops.\<close>

locale loop1 =
  fixes L and A and r

  assumes ordLoopAssum: "IsAnOrdLoop(L,A,r)"

  fixes neut ("\<zero>")
  defines neut_def[simp]: "\<zero> \<equiv> TheNeutralElement(L,A)"

  fixes looper (infixl "\<ra>" 69)
  defines looper_def[simp]: "x \<ra> y \<equiv> A`\<langle> x,y\<rangle>"

  fixes lesseq (infix "\<lsq>" 68)
  defines lesseq_def [simp]: "x \<lsq> y \<equiv> \<langle>x,y\<rangle> \<in> r"

  fixes sless (infix "\<ls>" 68)
  defines sless_def[simp]: "x \<ls> y \<equiv> x\<lsq>y \<and> x\<noteq>y"

  fixes nonnegative ("L\<^sup>+")
  defines nonnegative_def [simp]: "L\<^sup>+ \<equiv> Nonnegative(L,A,r)"

  fixes positive ("L\<^sub>+")
  defines positive_def[simp]: "L\<^sub>+ \<equiv> PositiveSet(L,A,r)"

  fixes leftdiv ("\<rm> _ \<ad> _")
  defines leftdiv_def[simp]: "\<rm>x\<ad>y \<equiv> LeftDiv(L,A)`\<langle>x,y\<rangle>"

  fixes rightdiv (infixl "\<rs>" 69)
  defines rightdiv_def[simp]:"x\<rs>y \<equiv> RightDiv(L,A)`\<langle>y,x\<rangle>"

text\<open>Theorems proven in the \<open>loop0\<close> locale are valid in the \<open>loop1\<close> locale\<close>

sublocale loop1 < loop0 L A looper
  using ordLoopAssum loop_loop0_valid unfolding IsAnOrdLoop_def by auto

text\<open>In this context $x \leq y$ implies that both $x$ and $y$ belong
  to $L$.\<close>

lemma (in loop1) lsq_members: assumes "x\<lsq>y" shows "x\<in>L" and "y\<in>L"
  using ordLoopAssum assms IsAnOrdLoop_def by auto

text\<open>In this context $x < y$ implies that both $x$ and $y$ belong
  to $L$.\<close>

lemma (in loop1) less_members: assumes "x\<ls>y" shows "x\<in>L" and "y\<in>L"
  using ordLoopAssum assms IsAnOrdLoop_def by auto

text\<open> In an ordered loop the order is translation invariant. \<close>

lemma (in loop1) ord_trans_inv: assumes "x\<lsq>y" "z\<in>L"
  shows "x\<ra>z \<lsq> y\<ra>z" and "z\<ra>x \<lsq> z\<ra>y"
proof -
  from ordLoopAssum assms have
    "(\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle> x,z\<rangle>,A`\<langle>y,z\<rangle>\<rangle> \<in> r) \<and> (\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle>z,x\<rangle>,A`\<langle>z,y\<rangle>\<rangle> \<in> r )"
    using lsq_members unfolding IsAnOrdLoop_def by blast
  with assms(1) show "x\<ra>z \<lsq> y\<ra>z" and "z\<ra>x \<lsq> z\<ra>y" by auto
qed

text\<open> In an ordered loop the strict order is translation invariant. \<close>

lemma (in loop1) strict_ord_trans_inv: assumes "x\<ls>y" "z\<in>L"
  shows "x\<ra>z \<ls> y\<ra>z" and "z\<ra>x \<ls> z\<ra>y"
proof -
  from assms have "x\<ra>z \<lsq> y\<ra>z" and "z\<ra>x \<lsq> z\<ra>y"
    using ord_trans_inv by auto
  moreover have "x\<ra>z \<noteq> y\<ra>z" and "z\<ra>x \<noteq> z\<ra>y"
  proof -
    { assume "x\<ra>z = y\<ra>z"
      with assms have "x=y" using less_members qg_cancel_right by blast
      with assms(1) have False by simp
    } thus "x\<ra>z \<noteq> y\<ra>z" by auto
    { assume "z\<ra>x = z\<ra>y"
      with assms have "x=y" using less_members qg_cancel_left by blast
      with assms(1) have False by simp
    } thus "z\<ra>x \<noteq> z\<ra>y" by auto
  qed
  ultimately show "x\<ra>z \<ls> y\<ra>z" and "z\<ra>x \<ls> z\<ra>y"
    by auto
qed

text\<open>We can cancel an element from both sides of an inequality on the right side. \<close>

lemma (in loop1) ineq_cancel_right: assumes "x\<in>L" "y\<in>L" "z\<in>L" and "x\<ra>z \<lsq> y\<ra>z"
  shows  "x\<lsq>y"
proof -
  from ordLoopAssum assms(1,2,3) have "\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle> x,z\<rangle>,A`\<langle>y,z\<rangle>\<rangle> \<in> r"
    unfolding IsAnOrdLoop_def by blast
  with assms(4) show "x\<lsq>y" by simp
qed

text\<open>We can cancel an element from both sides of a strict inequality on the right side. \<close>

lemma (in loop1) strict_ineq_cancel_right: assumes "x\<in>L" "y\<in>L" "z\<in>L" and "x\<ra>z \<ls> y\<ra>z"
  shows  "x\<ls>y"
  using assms ineq_cancel_right by auto

text\<open>We can cancel an element from both sides of an inequality on the left side. \<close>

lemma (in loop1) ineq_cancel_left: assumes "x\<in>L" "y\<in>L" "z\<in>L" and "z\<ra>x \<lsq> z\<ra>y"
  shows  "x\<lsq>y"
proof -
  from ordLoopAssum assms(1,2,3) have "\<langle>x,y\<rangle> \<in> r \<longleftrightarrow> \<langle>A`\<langle>z,x\<rangle>,A`\<langle>z,y\<rangle>\<rangle> \<in> r"
    unfolding IsAnOrdLoop_def by blast
  with assms(4) show "x\<lsq>y" by simp
qed

text\<open>We can cancel an element from both sides of a strict inequality on the left side. \<close>

lemma (in loop1) strict_ineq_cancel_left:
  assumes "x\<in>L" "y\<in>L" "z\<in>L" and "z\<ra>x \<ls> z\<ra>y"
  shows  "x\<ls>y"
  using assms ineq_cancel_left by auto

text\<open>The definition of the nonnegative set in the notation used in the \<open>loop1\<close> locale: \<close>

lemma (in loop1) nonneg_definition:
  shows "x \<in> L\<^sup>+ \<longleftrightarrow> \<zero> \<lsq> x" using ordLoopAssum IsAnOrdLoop_def Nonnegative_def by auto

text\<open>The nonnegative set is contained in the loop.\<close>

lemma (in loop1) nonneg_subset: shows "L\<^sup>+ \<subseteq> L"
  using Nonnegative_def by auto

text\<open>The positive set is contained in the loop.\<close>

lemma (in loop1) positive_subset: shows "L\<^sub>+ \<subseteq> L"
  using PositiveSet_def by auto

text\<open>The definition of the positive set in the notation used in the \<open>loop1\<close> locale: \<close>

lemma (in loop1) posset_definition:
  shows "x \<in> L\<^sub>+ \<longleftrightarrow> (\<zero>\<lsq>x \<and> x\<noteq>\<zero>)"
  using ordLoopAssum IsAnOrdLoop_def PositiveSet_def by auto

text\<open>Another form of the definition of the positive set in the notation used in the \<open>loop1\<close> locale: \<close>

lemma (in loop1) posset_definition1:
  shows "x \<in> L\<^sub>+ \<longleftrightarrow> \<zero>\<ls>x"
  using ordLoopAssum IsAnOrdLoop_def PositiveSet_def by auto

text\<open> The order in an ordered loop is antisymmeric. \<close>

lemma (in loop1) loop_ord_antisym: assumes "x\<lsq>y" and "y\<lsq>x"
  shows "x=y"
proof -
  from ordLoopAssum assms have "antisym(r)" "\<langle>x,y\<rangle> \<in> r" "\<langle>y,x\<rangle> \<in> r"
    unfolding IsAnOrdLoop_def IsPartOrder_def by auto
  then show "x=y" by (rule Fol1_L4)
qed

text\<open> The loop order is transitive. \<close>

lemma (in loop1) loop_ord_trans: assumes "x\<lsq>y" and "y\<lsq>z" shows "x\<lsq>z"
proof -
  from ordLoopAssum assms have "trans(r)" and "\<langle>x,y\<rangle> \<in> r \<and> \<langle>y,z\<rangle> \<in> r"
    unfolding IsAnOrdLoop_def IsPartOrder_def by auto
  then have "\<langle>x,z\<rangle> \<in> r" by (rule Fol1_L3)
  thus ?thesis by simp
qed

text\<open> The loop order is reflexive. \<close>
lemma (in loop1) loop_ord_refl: assumes "x\<in>L" shows "x\<lsq>x"
  using assms ordLoopAssum unfolding IsAnOrdLoop_def IsPartOrder_def refl_def
  by simp

text\<open> A form of mixed transitivity for the strict order: \<close>

lemma (in loop1) loop_strict_ord_trans: assumes "x\<lsq>y" and "y\<ls>z"
  shows "x\<ls>z"
proof -
  from assms have "x\<lsq>y" and "y\<lsq>z" by auto
  then have "x\<lsq>z" by (rule loop_ord_trans)
  with assms show "x\<ls>z" using loop_ord_antisym by auto
qed

text\<open> Another form of mixed transitivity for the strict order: \<close>

lemma (in loop1) loop_strict_ord_trans1: assumes "x\<ls>y" and "y\<lsq>z"
  shows "x\<ls>z"
proof -
  from assms have "x\<lsq>y" and "y\<lsq>z" by auto
  then have "x\<lsq>z" by (rule loop_ord_trans)
  with assms show "x\<ls>z" using loop_ord_antisym by auto
qed

text\<open> Yet another form of mixed transitivity for the strict order: \<close>

lemma (in loop1) loop_strict_ord_trans2: assumes "x\<ls>y" and "y\<ls>z"
  shows "x\<ls>z"
proof -
  from assms have "x\<lsq>y" and "y\<lsq>z" by auto
  then have "x\<lsq>z" by (rule loop_ord_trans)
  with assms show "x\<ls>z" using loop_ord_antisym by auto
qed

text\<open> We can move an element to the other side of an inequality. Well, not exactly, but
  our notation creates an illusion to that effect. \<close>

lemma (in loop1) lsq_other_side: assumes "x\<lsq>y"
  shows "\<zero> \<lsq> \<rm>x\<ad>y"  "(\<rm>x\<ad>y) \<in> L\<^sup>+" "\<zero> \<lsq> y\<rs>x" "(y\<rs>x) \<in> L\<^sup>+"
proof -
  from assms have "x\<in>L" "y\<in>L" "\<zero>\<in>L" "(\<rm>x\<ad>y) \<in> L" "(y\<rs>x) \<in> L"
    using lsq_members neut_props_loop(1) lrdiv_props(2,5) by auto
  then have "x = x\<ra>\<zero>" and "y = x\<ra>(\<rm>x\<ad>y)" using neut_props_loop(2) lrdiv_props(6)
    by auto
  with assms have "x\<ra>\<zero> \<lsq> x\<ra>(\<rm>x\<ad>y)" by simp
  with \<open>x\<in>L\<close> \<open>\<zero>\<in>L\<close> \<open>(\<rm>x\<ad>y) \<in> L\<close> show "\<zero> \<lsq> \<rm>x\<ad>y" using ineq_cancel_left
    by simp
  then show "(\<rm>x\<ad>y) \<in> L\<^sup>+" using nonneg_definition by simp
  from \<open>x\<in>L\<close> \<open>y\<in>L\<close> have "x = \<zero>\<ra>x" and "y = (y\<rs>x)\<ra>x"
    using neut_props_loop(2) lrdiv_props(3) by auto
  with assms have "\<zero>\<ra>x \<lsq> (y\<rs>x)\<ra>x" by simp
  with \<open>x\<in>L\<close> \<open>\<zero>\<in>L\<close> \<open>(y\<rs>x) \<in> L\<close> show "\<zero> \<lsq> y\<rs>x" using ineq_cancel_right
    by simp
  then show "(y\<rs>x) \<in> L\<^sup>+" using  nonneg_definition by simp
qed

text\<open> We can move an element to the other side of a strict inequality. \<close>

lemma (in loop1) ls_other_side: assumes "x\<ls>y"
  shows "\<zero> \<ls> \<rm>x\<ad>y"  "(\<rm>x\<ad>y) \<in> L\<^sub>+" "\<zero> \<ls> y\<rs>x" "(y\<rs>x) \<in> L\<^sub>+"
proof -
  from assms have "x\<in>L" "y\<in>L" "\<zero>\<in>L" "(\<rm>x\<ad>y) \<in> L" "(y\<rs>x) \<in> L"
    using lsq_members neut_props_loop(1) lrdiv_props(2,5) by auto
  then have "x = x\<ra>\<zero>" and "y = x\<ra>(\<rm>x\<ad>y)" using neut_props_loop(2) lrdiv_props(6)
    by auto
  with assms have "x\<ra>\<zero> \<ls> x\<ra>(\<rm>x\<ad>y)" by simp
  with \<open>x\<in>L\<close> \<open>\<zero>\<in>L\<close> \<open>(\<rm>x\<ad>y) \<in> L\<close> show "\<zero> \<ls> \<rm>x\<ad>y" using strict_ineq_cancel_left
    by simp
  then show "(\<rm>x\<ad>y) \<in> L\<^sub>+" using posset_definition1 by simp
  from \<open>x\<in>L\<close> \<open>y\<in>L\<close> have "x = \<zero>\<ra>x" and "y = (y\<rs>x)\<ra>x"
    using neut_props_loop(2) lrdiv_props(3) by auto
  with assms have "\<zero>\<ra>x \<ls> (y\<rs>x)\<ra>x" by simp
  with \<open>x\<in>L\<close> \<open>\<zero>\<in>L\<close> \<open>(y\<rs>x) \<in> L\<close> show "\<zero> \<ls> y\<rs>x" using strict_ineq_cancel_right
    by simp
  then show "(y\<rs>x) \<in> L\<^sub>+" using posset_definition1 by simp
qed

text\<open>We can add sides of inequalities.\<close>

lemma (in loop1) add_ineq: assumes "x\<lsq>y" "z\<lsq>t"
  shows "x\<ra>z \<lsq> y\<ra>t"
proof -
  from assms have "x\<ra>z \<lsq> y\<ra>z"
    using lsq_members(1) ord_trans_inv(1) by simp
  with assms show ?thesis using lsq_members(2) ord_trans_inv(2) loop_ord_trans
    by simp
qed

text\<open>We can add sides of strict inequalities. The proof uses a lemma that
  relies on the antisymmetry of the order relation.\<close>

lemma (in loop1) add_ineq_strict: assumes "x\<ls>y" "z\<ls>t"
  shows "x\<ra>z \<ls> y\<ra>t"
proof -
  from assms have "x\<ra>z \<ls> y\<ra>z"
    using less_members(1) strict_ord_trans_inv(1) by auto
  moreover from assms have "y\<ra>z \<ls> y\<ra>t"
    using less_members(2) strict_ord_trans_inv(2) by auto
  ultimately show ?thesis by (rule loop_strict_ord_trans2)
qed

text\<open>We can add sides of inequalities one of which is strict. \<close>

lemma (in loop1) add_ineq_strict1: assumes "x\<lsq>y" "z\<ls>t"
  shows "x\<ra>z \<ls> y\<ra>t" and "z\<ra>x \<ls> t\<ra>y"
proof -
    from assms have "x\<ra>z \<lsq> y\<ra>z"
      using less_members(1) ord_trans_inv(1) by auto
    with assms show "x\<ra>z \<ls> y\<ra>t"
      using lsq_members(2) strict_ord_trans_inv(2) loop_strict_ord_trans
      by blast
    from assms have "z\<ra>x \<ls> t\<ra>x"
      using lsq_members(1) strict_ord_trans_inv(1) by simp
    with assms show "z\<ra>x \<ls> t\<ra>y"
      using less_members(2) ord_trans_inv(2) loop_strict_ord_trans1
      by blast
qed

text\<open>Subtracting a positive element decreases the value. \<close>

lemma (in loop1) subtract_pos: assumes "x\<in>L" "\<zero>\<ls>y"
  shows "x\<rs>y \<ls> x" and "(\<rm>y\<ad>x) \<ls> x"
proof -
  from assms(2) have "y\<in>L" using less_members(2) by simp
  from assms(1) have "x\<lsq>x"
    using ordLoopAssum unfolding IsAnOrdLoop_def IsPartOrder_def refl_def
    by simp
  with assms(2) have "x\<ra>\<zero> \<ls> x\<ra>y"
    using add_ineq_strict1(1) by simp
  with assms \<open>y\<in>L\<close> show "x\<rs>y \<ls> x"
    using neut_props_loop(2) lrdiv_props(3) lrdiv_props(2) strict_ineq_cancel_right
    by simp
  from assms(2) \<open>x\<lsq>x\<close> have "\<zero>\<ra>x \<ls> y\<ra>x"
    using add_ineq_strict1(2) by simp
  with assms \<open>y\<in>L\<close> show "(\<rm>y\<ad>x) \<ls> x"
    using neut_props_loop(2) lrdiv_props(6) lrdiv_props(5) strict_ineq_cancel_left
    by simp
qed

end


section \<open>Example theory file for getting acquainted with Isabelle\<close>
(*<*)
theory Example
imports Main

begin
(*>*)
subsection \<open>Terms\<close>
text \<open>
  We can write logical formulae and terms in the usual notation.
  Connectives such as @{text "\<not>"},@{text "\<or>"}, @{text "\<and>"} etc. can be typed using the backslash
  @{text "\\"} followed by the name of the sign. I.e. @{text "\\not"} for @{text "\<not>"}.
  Note that during typing @{text "\\not"} at some point there will be a pop-up menu
  offering you certain auto completion suggestions that you can accept by
  pressing the tab key.
\<close>

subsection \<open>Types\<close>
text \<open>
  All terms (and also constant symbols, variables etc.) are associated
  a type. The type @{type "bool"} is the type of all Boolean-values objects
  (e.g. truth values).
  New types can be inserted at will.
\<close>

typedecl "i" -- "Create a new type i for the type of individuals"

subsection \<open>Constants\<close>
text \<open>
  New constants can be defined using the @{text "consts"} keyword.
  You need to specify the type of the constant explicitly.
\<close>
subsection \<open>Terms and Formulas\<close>
text \<open>
  In higher-order logic (HOL), terms are all well-formed expressions
  that can be expressed within the logic. A term has a unique type, such
  as in @{term "f(A) :: i"} where the term @{term "f(A)"} has type
  @{type "i"}. Terms of type @{type "bool"} are called "formulas".
\<close>

subsubsection \<open>Example formula 1\<close>
text \<open>If it's raining the street will get wet\<close>

consts raining :: "bool" -- "constant symbol for raining"
consts wet :: "i \<Rightarrow> bool" -- "predicate symbol for wet"
consts street :: "i" -- "constant symbol for the street"

prop "raining \<longrightarrow> wet(street)" -- "raining implies street-is-wet"
prop "wet(street) \<longrightarrow> raining"

subsubsection \<open>Example formula 2\<close>
consts good :: "i \<Rightarrow> bool" -- "predicate symbol for being good"

prop "good(A)" -- "A is good"
text \<open>A is a free variable of the above term, hence it is not closed\<close>

subsubsection \<open>Example formula 3\<close>

prop "\<forall>A. good(A)" -- "everything is good"
text \<open>A is a a bound variable of the above term, which is universally qualified.\<close>

subsection \<open>Proofs\<close>
text \<open>We will learn how to formalize proofs in Isabelle throughout this course.\<close>

subsubsection \<open>Proofs with handy keywords\<close>

theorem MyFirstTheorem:
  assumes "A"
  shows "B \<longrightarrow> A"
proof -
  {
    assume "B"
    from assms have "A" by - -- "Iterate the fact that A holds by assumptions using the - sign"
  }
  then have "B \<longrightarrow> A" by (rule impI)
  thus ?thesis .
qed

(*
theorem MySecondTheorem:
  shows "((A \<longrightarrow> B) \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> (B \<longrightarrow> C))"
proof -
  {
  assume "(A \<longrightarrow> B) \<longrightarrow> C"
  assume "(A \<longrightarrow> B)"
*)
subsubsection \<open>Proofs with labels\<close>

theorem ExcludedMiddle:
 shows "A \<or> \<not> A"
 proof -
   {
      assume 1: "\<not> (A \<or> \<not> A)"
      {
        assume 2: "\<not> A"
        from 2 have 3: "A \<or> \<not> A" by (rule disjI2)
        from 1 3 have 4: "False" by (rule notE)
      } note 5=this
      from 5 have 6: "A" by (rule ccontr)
      from 6 have 7: "A \<or> \<not> A" by (rule disjI1)
      from 1 7 have "False" by (rule notE)
   }
   from this have "A \<or> \<not> A" by (rule ccontr)
   thus ?thesis .
 qed

theorem Exm2:
  shows "A \<or> \<not> A"
by simp

(*
theorem MyFirstTheorem2:
  assumes 1: "A"
  shows "B \<longrightarrow> A"
proof -
  {
    assume "B"
    from 1 have "A" by -
  } note 2 = this
  from 2 have "B \<longrightarrow> A" by (rule impI)
  thus ?thesis .
qed
*)

subsubsection \<open>Using the proofs\<close>
text \<open>
  We can now derive simple facts of the above theorem.
\<close>

corollary ThatFollowsDirectly:
  assumes "A"
  shows "P(A) \<longrightarrow> A"
using assms by (rule MyFirstTheorem[where B = "P(A)"])

subsection \<open>Exercise 1 \<close>
consts ship :: "i"
consts isBlue :: "i \<Rightarrow> bool"
consts isHuge :: "i \<Rightarrow> bool"

prop "isHuge(ship) \<and> isBlue(ship)"

consts I :: "i"
consts SunShining :: "bool"
consts Sad :: "i \<Rightarrow> bool"

prop "\<not>SunShining \<longrightarrow> Sad(I)"

consts isRaining :: "bool"

prop "isRaining \<and> \<not> isRaining"

consts going :: "i \<Rightarrow> bool"
consts she :: "i"

prop "going(I) \<longleftrightarrow> going(she)"

consts lovesIceCream :: "i \<Rightarrow> bool"
consts lovesChocolate :: "i \<Rightarrow> bool"

prop "\<forall>i.(lovesIceCream(i)\<or>lovesChocolate(i))"

prop "\<exists>i.(lovesIceCream(i)\<and>lovesChocolate(i))"

consts CanPlayTogether :: "i \<times> i \<Rightarrow> bool"

prop "\<forall>x.\<exists>y.(CanPlayTogether(x, y))"

consts isMean :: "i \<Rightarrow> bool"

prop "\<forall>x. isMean(x) \<longrightarrow> \<not> (\<exists>y. CanPlayTogether(x, y))"

consts isDog :: "i \<Rightarrow> bool"
consts isCat :: "i \<Rightarrow> bool"
consts annoying :: "(i \<Rightarrow> bool) \<Rightarrow> bool"

prop "\<forall>P. annoying(P) \<longrightarrow> ((\<forall>x. isCat(x) \<and> P(x)) \<longleftrightarrow> (\<forall>y. isDog(y) \<and> P(y)))"

subsection \<open>Exercise 2\<close>

theorem a:
  assumes 1: "A \<and> B \<longrightarrow> C" and
  2: "B \<longrightarrow> A" and
  3: "B"
  shows "C"
  proof -
    from 2 3 have 4: "A" by (rule mp)
    from 4 3 have 5: "A \<and> B" by (rule conjI)
    from 1 5 have "C" by (rule mp)
  thus ?thesis .
qed

theorem b:
  assumes 1: "A"
  shows "B \<longrightarrow> A"
  proof -
    {
      assume B
      from assms have "A" by -
    }
    from this have "B \<longrightarrow> A" by (rule impI)
  thus ?thesis .
qed

theorem c:
  assumes 1: "A \<longrightarrow> (B \<longrightarrow> C)"
  shows "B \<longrightarrow> (A \<longrightarrow> C)"
  proof -
    {
      assume 2: "B"
      {
        assume 3: "A"
        from 1 3 have 4: "B \<longrightarrow> C" by (rule mp)
        from 4 2 have "C" by (rule mp)
      }
      from this have "A \<longrightarrow> C" by (rule impI)
    }
    from this have "B \<longrightarrow> (A \<longrightarrow> C)" by (rule impI)
    thus ?thesis .
qed

theorem d:
  assumes 1: "\<not>A"
  shows "A \<longrightarrow> B"
  proof -
    {
      assume 2: "A"
      {
        assume 3: "\<not>B"
        from 1 2 have "False" by (rule notE)
      }
      from this have "B" by (rule ccontr)
    }
    from this have "A \<longrightarrow> B" by (rule impI)
  thus ?thesis .
qed

theorem e:
 shows "A \<or> \<not> A"
 proof -
   {
      assume 1: "\<not> (A \<or> \<not> A)"
      {
        assume 2: "\<not> A"
        from 2 have 3: "A \<or> \<not> A" by (rule disjI2)
        from 1 3 have 4: "False" by (rule notE)
      } note 5=this
      from 5 have 6: "A" by (rule ccontr)
      from 6 have 7: "A \<or> \<not> A" by (rule disjI1)
      from 1 7 have "False" by (rule notE)
   }
   from this have "A \<or> \<not> A" by (rule ccontr)
   thus ?thesis .
 qed

(*<*)
end
(*>*)