theory RC2
imports Main
begin

datatype 'a rc =
  Leaf 'a |
  Node 'a "'a rc" "'a rc"

fun getValue :: "'a rc \<Rightarrow> bool list \<Rightarrow> 'a" where
  "getValue (Leaf x) ys  = x" |
  "getValue (Node x l r) [] = x" |
  "getValue (Node x l r) (False # ys) = getValue l ys" |
  "getValue (Node x l r) (True # ys) = getValue r ys"

fun getTree :: "'a rc \<Rightarrow> bool list \<Rightarrow> 'a rc" where
  "getTree (Leaf x) ys = (Leaf x)" |
  "getTree r [] = r" |
  "getTree (Node x l r) (False # ys) = getTree l ys" |
  "getTree (Node x l r) (True # ys) = getTree r ys"

fun fmap :: "('a => 'b) => 'a rc => 'b rc" where
  "fmap f (Leaf x) = Leaf (f x)" |
  "fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)"

fun unit :: "'a \<Rightarrow> 'a rc" where
  "unit x = Leaf x"

fun kleisli :: "('a \<Rightarrow> 'b rc) \<Rightarrow> 'a rc \<Rightarrow> bool list \<Rightarrow> 'b rc" where
  "kleisli f (Leaf x) word = getTree (f x) word" |
  "kleisli f (Node x l r) word = Node (getValue (f x) word) (kleisli f l (word @ [False])) (kleisli f r (word @ [True]))"

fun flatMap :: "('a \<Rightarrow> 'b rc) \<Rightarrow> 'a rc \<Rightarrow> 'b rc" where
  "flatMap f x = kleisli f x []"

fun inTree :: "'a rc \<Rightarrow> bool list \<Rightarrow> bool" where
  "inTree t [] = True" |
  "inTree (Leaf x) ys = False" |
  "inTree (Node x l r) (False # ys) = inTree l ys" |
  "inTree (Node x l r) (True # ys) = inTree r ys"

lemma [simp]: "getTree t ys = Leaf a \<Longrightarrow> getTree t (ys @ b) = Leaf a"
  apply (induct t ys rule: getTree.induct)
  apply simp_all
  done

lemma "flatMap f (unit x) = f x"
  by simp

lemma [simp]: "kleisli unit t ys = t"
  apply (induction t arbitrary: ys)
  apply auto
  done

lemma "(flatMap unit) x = x"
  by auto

lemma [simp]: "getValue (k (getValue t [])) [] = getValue (kleisli k t []) []"
  apply (induct t)
  apply auto
  done

lemma "getTree (Node a l r) (b # ys) = getTree (getTree (Node a l r) [b]) ys"
  apply (induct b)
  apply auto
  done

lemma tree: "getTree t (xs @ ys) = getTree (getTree t xs) ys"
  apply (induction t xs rule:getTree.induct)
  apply auto
  done

lemma [simp]: "getTree (getTree t xs) ys = getTree t (xs @ ys)"
  by (metis tree)

lemma tree2: "getTree t (x # ys) = getTree (getTree t [x]) ys"
  apply simp
  done

(*lemma "kleisli k (getTree (Node a t1 t2) (aa # ys)) (aa # ys) =
       getTree (Node (getValue (k a) []) (kleisli k t1 [False]) (kleisli k t2 [True]))
        (aa # ys)"
  apply (induct aa)
  apply auto
  apply (induct t2)
  apply auto*)

(*lemma "kleisli k (getTree (Node a t1 t2) ys) ys =
       getTree (Node (getValue (k a) []) (kleisli k t1 [False]) (kleisli k t2 [True])) ys"
  apply (induct ys)
  apply auto *)

lemma "getValue ((flatMap k) ((flatMap h) t)) []  = getValue ((flatMap (\<lambda>x. (flatMap k) (h x))) t) []"
  apply auto
  apply (induct t)
  apply auto
  done

(*lemma "inTree ((flatMap k) ((flatMap h) t)) ys  = inTree ((flatMap (\<lambda>x. (flatMap k) (h x))) t) ys"
  apply auto
  apply (induct t arbitrary:ys)
  apply auto
  apply (induct ys)
  apply auto

lemma "getValue ((flatMap k) ((flatMap h) t)) ys  = getValue ((flatMap (\<lambda>x. (flatMap k) (h x))) t) ys"
  apply auto
  apply (induct t arbitrary: ys)
  apply auto
  apply (induct ys)
  apply auto

lemma "getValue (kleisli k (getTree t ys) (xs @ ys)) [] = getValue (getTree (kleisli k t xs) ys) []"
  apply (induct t xs rule: getValue.induct)
  apply auto
  apply (induct ys)
  apply auto
*)

lemma list: "xs @ a # ys = (xs @ [a]) @ ys"
  by auto

lemma kleisli: "kleisli k (getTree t ys) (xs @ ys) = getTree (kleisli k t xs) ys"
  apply (induct t ys arbitrary: xs rule:getTree.induct )
  apply auto
  apply (metis list)
  apply (metis list)
  done

(*
lemma "kleisli k (getTree t ys) ys = getTree (kleisli k t []) ys \<Longrightarrow>
            kleisli k (getTree t ys) (x # ys) = getTree (kleisli k t [x]) ys"
  apply (induct x)
  apply (induct ys)
  apply auto

lemma "kleisli k (getTree t ys) ys = getTree (kleisli k t []) ys"
  apply (induct t ys rule: getTree.induct)
  apply auto *)

lemma getValTree: "getValue t (xs @ ys) = getValue (getTree t xs) ys"
  apply (induct t xs rule: getTree.induct)
  apply auto
  done

lemma getValKleisli: "getValue (k (getValue t ys)) (xs @ ys) = getValue (kleisli k t xs) ys"
  apply (induct t ys arbitrary: xs rule:getValue.induct)
  apply auto
  apply (metis getValTree)
  apply (metis append_Cons append_Nil append_assoc)
  apply (metis append_Cons append_Nil append_assoc)
  done

lemma kleisli2: "kleisli k (kleisli h t ys) ys = kleisli (\<lambda>x. kleisli k (h x) []) t ys"
  apply (induct t arbitrary: ys)
  apply auto
  apply (metis append_Nil kleisli)
  apply (metis append_Nil getValKleisli)
  done

lemma "(flatMap k) ((flatMap h) t) = (flatMap (\<lambda>x. (flatMap k) (h x))) t"
  apply auto
  apply (induction t)
  apply auto
  apply (metis kleisli2)
  apply (metis kleisli2)
  done

end


(* Title: HOL/Library/Uprod.thy
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Unordered pairs\<close>

theory Uprod imports "MainRLT" begin

typedef ('a, 'b) commute = "{f :: 'a \<Rightarrow> 'a \<Rightarrow> 'b. \<forall>x y. f x y = f y x}"
  morphisms apply_commute Abs_commute
  by auto

setup_lifting type_definition_commute

lemma apply_commute_commute: "apply_commute f x y = apply_commute f y x"
by(transfer) simp

context includes lifting_syntax begin

lift_definition rel_commute :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'c) commute \<Rightarrow> ('b, 'd) commute \<Rightarrow> bool"
is "\<lambda>A B. A ===> A ===> B" .

end

definition eq_upair :: "('a \<times> 'a) \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool"
where "eq_upair = (\<lambda>(a, b) (c, d). a = c \<and> b = d \<or> a = d \<and> b = c)"

lemma eq_upair_simps [simp]:
  "eq_upair (a, b) (c, d) \<longleftrightarrow> a = c \<and> b = d \<or> a = d \<and> b = c"
by(simp add: eq_upair_def)

lemma equivp_eq_upair: "equivp eq_upair"
by(auto simp add: equivp_def fun_eq_iff)

quotient_type 'a uprod = "'a \<times> 'a" / eq_upair by(rule equivp_eq_upair)

lift_definition Upair :: "'a \<Rightarrow> 'a \<Rightarrow> 'a uprod" is Pair parametric Pair_transfer[of "A" "A" for A] .

lemma uprod_exhaust [case_names Upair, cases type: uprod]:
  obtains a b where "x = Upair a b"
by transfer fastforce

lemma Upair_inject [simp]: "Upair a b = Upair c d \<longleftrightarrow> a = c \<and> b = d \<or> a = d \<and> b = c"
by transfer auto

code_datatype Upair

lift_definition case_uprod :: "('a, 'b) commute \<Rightarrow> 'a uprod \<Rightarrow> 'b" is case_prod
  parametric case_prod_transfer[of A A for A] by auto

lemma case_uprod_simps [simp, code]: "case_uprod f (Upair x y) = apply_commute f x y"
by transfer auto

lemma uprod_split: "P (case_uprod f x) \<longleftrightarrow> (\<forall>a b. x = Upair a b \<longrightarrow> P (apply_commute f a b))"
by transfer auto

lemma uprod_split_asm: "P (case_uprod f x) \<longleftrightarrow> \<not> (\<exists>a b. x = Upair a b \<and> \<not> P (apply_commute f a b))"
by transfer auto

lift_definition not_equal :: "('a, bool) commute" is "(\<noteq>)" by auto

lemma apply_not_equal [simp]: "apply_commute not_equal x y \<longleftrightarrow> x \<noteq> y"
by transfer simp

definition proper_uprod :: "'a uprod \<Rightarrow> bool"
where "proper_uprod = case_uprod not_equal"

lemma proper_uprod_simps [simp, code]: "proper_uprod (Upair x y) \<longleftrightarrow> x \<noteq> y"
by(simp add: proper_uprod_def)

context includes lifting_syntax begin

private lemma set_uprod_parametric':
  "(rel_prod A A ===> rel_set A) (\<lambda>(a, b). {a, b}) (\<lambda>(a, b). {a, b})"
by transfer_prover

lift_definition set_uprod :: "'a uprod \<Rightarrow> 'a set" is "\<lambda>(a, b). {a, b}"
  parametric set_uprod_parametric' by auto

lemma set_uprod_simps [simp, code]: "set_uprod (Upair x y) = {x, y}"
by transfer simp

lemma finite_set_uprod [simp]: "finite (set_uprod x)"
by(cases x) simp

private lemma map_uprod_parametric':
  "((A ===> B) ===> rel_prod A A ===> rel_prod B B) (\<lambda>f. map_prod f f) (\<lambda>f. map_prod f f)"
by transfer_prover

lift_definition map_uprod :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a uprod \<Rightarrow> 'b uprod" is "\<lambda>f. map_prod f f"
  parametric map_uprod_parametric' by auto

lemma map_uprod_simps [simp, code]: "map_uprod f (Upair x y) = Upair (f x) (f y)"
by transfer simp

private lemma rel_uprod_transfer':
  "((A ===> B ===> (=)) ===> rel_prod A A ===> rel_prod B B ===> (=))
   (\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c) (\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c)"
by transfer_prover

lift_definition rel_uprod :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a uprod \<Rightarrow> 'b uprod \<Rightarrow> bool"
  is "\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c" parametric rel_uprod_transfer'
by auto

lemma rel_uprod_simps [simp, code]:
  "rel_uprod R (Upair a b) (Upair c d) \<longleftrightarrow> R a c \<and> R b d \<or> R a d \<and> R b c"
by transfer auto

lemma Upair_parametric [transfer_rule]: "(A ===> A ===> rel_uprod A) Upair Upair"
unfolding rel_fun_def by transfer auto

lemma case_uprod_parametric [transfer_rule]:
  "(rel_commute A B ===> rel_uprod A ===> B) case_uprod case_uprod"
unfolding rel_fun_def by transfer(force dest: rel_funD)

end

bnf uprod: "'a uprod"
  map: map_uprod
  sets: set_uprod
  bd: natLeq
  rel: rel_uprod
proof -
  show "map_uprod id = id" unfolding fun_eq_iff by transfer auto
  show "map_uprod (g \<circ> f) = map_uprod g \<circ> map_uprod f" for f :: "'a \<Rightarrow> 'b" and g :: "'b \<Rightarrow> 'c"
    unfolding fun_eq_iff by transfer auto
  show "map_uprod f x = map_uprod g x" if "\<And>z. z \<in> set_uprod x \<Longrightarrow> f z = g z"
    for f :: "'a \<Rightarrow> 'b" and g x using that by transfer auto
  show "set_uprod \<circ> map_uprod f = (`) f \<circ> set_uprod" for f :: "'a \<Rightarrow> 'b" by transfer auto
  show "card_order natLeq" by(rule natLeq_card_order)
  show "BNF_Cardinal_Arithmetic.cinfinite natLeq" by(rule natLeq_cinfinite)
  show "ordLeq3 (card_of (set_uprod x)) natLeq" for x :: "'a uprod"
    by (auto simp flip: finite_iff_ordLess_natLeq intro: ordLess_imp_ordLeq)
  show "rel_uprod R OO rel_uprod S \<le> rel_uprod (R OO S)"
    for R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and S :: "'b \<Rightarrow> 'c \<Rightarrow> bool" by(rule predicate2I)(transfer; auto)
  show "rel_uprod R = (\<lambda>x y. \<exists>z. set_uprod z \<subseteq> {(x, y). R x y} \<and> map_uprod fst z = x \<and> map_uprod snd z = y)"
    for R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" by transfer(auto simp add: fun_eq_iff)
qed

lemma pred_uprod_code [simp, code]: "pred_uprod P (Upair x y) \<longleftrightarrow> P x \<and> P y"
by(simp add: pred_uprod_def)

instantiation uprod :: (equal) equal begin

definition equal_uprod :: "'a uprod \<Rightarrow> 'a uprod \<Rightarrow> bool"
where "equal_uprod = (=)"

lemma equal_uprod_code [code]:
  "HOL.equal (Upair x y) (Upair z u) \<longleftrightarrow> x = z \<and> y = u \<or> x = u \<and> y = z"
unfolding equal_uprod_def by simp

instance by standard(simp add: equal_uprod_def)
end

quickcheck_generator uprod constructors: Upair

lemma UNIV_uprod: "UNIV = (\<lambda>x. Upair x x) ` UNIV \<union> (\<lambda>(x, y). Upair x y) ` Sigma UNIV (\<lambda>x. UNIV - {x})"
apply(rule set_eqI)
subgoal for x by(cases x) auto
done

context begin
private lift_definition upair_inv :: "'a uprod \<Rightarrow> 'a"
is "\<lambda>(x, y). if x = y then x else undefined" by auto

lemma finite_UNIV_prod [simp]:
  "finite (UNIV :: 'a uprod set) \<longleftrightarrow> finite (UNIV :: 'a set)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  hence "finite (range (\<lambda>x :: 'a. Upair x x))" by(rule finite_subset[rotated]) simp
  hence "finite (upair_inv ` range (\<lambda>x :: 'a. Upair x x))" by(rule finite_imageI)
  also have "upair_inv (Upair x x) = x" for x :: 'a by transfer simp
  then have "upair_inv ` range (\<lambda>x :: 'a. Upair x x) = UNIV" by(auto simp add: image_image)
  finally show ?rhs .
qed(simp add: UNIV_uprod)

end

lemma card_UNIV_uprod:
  "card (UNIV :: 'a uprod set) = card (UNIV :: 'a set) * (card (UNIV :: 'a set) + 1) div 2"
  (is "?UPROD = ?A * _ div _")
proof(cases "finite (UNIV :: 'a set)")
  case True
  from True obtain f :: "nat \<Rightarrow> 'a" where bij: "bij_betw f {0..<?A} UNIV"
    by (blast dest: ex_bij_betw_nat_finite)
  hence [simp]: "f ` {0..<?A} = UNIV" by(rule bij_betw_imp_surj_on)
  have "UNIV = (\<lambda>(x, y). Upair (f x) (f y)) ` (SIGMA x:{0..<?A}. {..x})"
    apply(rule set_eqI)
    subgoal for x
      apply(cases x)
      apply(clarsimp)
      subgoal for a b
        apply(cases "inv_into {0..<?A} f a \<le> inv_into {0..<?A} f b")
        subgoal by(rule rev_image_eqI[where x="(inv_into {0..<?A} f _, inv_into {0..<?A} f _)"])
                  (auto simp add: inv_into_into[where A="{0..<?A}" and f=f, simplified] intro: f_inv_into_f[where f=f, symmetric])
        subgoal
          apply(simp only: not_le)
          apply(drule less_imp_le)
          apply(rule rev_image_eqI[where x="(inv_into {0..<?A} f _, inv_into {0..<?A} f _)"])
          apply(auto simp add: inv_into_into[where A="{0..<?A}" and f=f, simplified] intro: f_inv_into_f[where f=f, symmetric])
          done
        done
      done
    done
  hence "?UPROD = card \<dots>" by simp
  also have "\<dots> = card (SIGMA x:{0..<?A}. {..x})"
    apply(rule card_image)
    using bij[THEN bij_betw_imp_inj_on]
    by(simp add: inj_on_def Ball_def)(metis leD le_eq_less_or_eq le_less_trans)
  also have "\<dots> = sum Suc {0..<?A}"
    by (subst card_SigmaI) simp_all
  also have "\<dots> = sum of_nat {Suc 0..?A}"
    using sum.atLeastLessThan_reindex [symmetric, of Suc 0 ?A id]
    by (simp del: sum.op_ivl_Suc add: atLeastLessThanSuc_atLeastAtMost)
  also have "\<dots> = ?A * (?A + 1) div 2"
    using gauss_sum_from_Suc_0 [of ?A, where ?'a = nat] by simp
  finally show ?thesis .
qed simp

(**********************)
(* The commute type has a wide definition *)

(* *)
definition isCommute :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool" where
"isCommute f = (\<forall>x y. f x y = f y x)"

lemmas type_definition_isCommute =
   commute.type_definition_commute[unfolded isCommute_def[symmetric]]

(* *)
lemma isCommute_aux: "isCommute = isCommute" ..
local_setup \<open>RLTHM @{binding isCommute_rlt_neper_param} @{thm isCommute_aux}\<close>
thm isCommute_rlt_neper_param

lemma isCommute_rlt_simp[simp]:
"neper R1 \<Longrightarrow> neper R2 \<Longrightarrow>
 isCommute_rlt R1 R2 f = (\<forall>a b. R1 a a \<and> R1 b b \<longrightarrow> R2 (f a b) (f b a))"
unfolding isCommute_rlt_def by auto

(* *)

definition gg :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b"
where "gg R1 R2 \<equiv> \<lambda>f a b. getRepr' R2 (f (getRepr' R1 a) (getRepr' R1 b))"

lemma bij_upto_gg:
assumes R: "neper R1" "neper R2"
shows
"bij_upto
 (restr (rel_fun R1 (rel_fun R1 R2)) isCommute)
 (restr (rel_fun R1 (rel_fun R1 R2)) (isCommute_rlt R1 R2)) (gg R1 R2)"
apply(rule bij_uptoI)
  subgoal apply(rule neper_restr)
    subgoal using R by simp
    subgoal apply(rule exI[of _ "\<lambda>a b. SOME x. R2 x x"], safe)
      subgoal using R by (simp add: neper_Some)
      subgoal using R unfolding rel_fun_def by (simp add: neper_Some) . .
  subgoal for f f' unfolding restr_def apply safe
    subgoal using R unfolding rel_fun_def gg_def
    	by (smt (verit, best) getRepr'_def geterRepr_related neper_per per_def)
    subgoal using R unfolding isCommute_def[of f]
    unfolding gg_def rel_fun_def
    by simp (metis (no_types, lifting) getRepr'_def getReprOn getReprOn_UNIV geterRepr_related
      neper_Some neper_getRepr_eq)
    subgoal using R unfolding isCommute_def[of f']
    unfolding gg_def rel_fun_def
    by simp (metis (no_types, lifting) getRepr'_def getReprOn getReprOn_UNIV geterRepr_related
      neper_Some neper_getRepr_eq) .
  subgoal for f f' unfolding restr_def apply safe
    unfolding rel_fun_def gg_def
    by (smt (z3) R getRepr'_def getRepr_neper mem_Collect_eq neper_classes_eq neper_getRepr_eq)
  subgoal for g apply(rule exI[of _ "gg R1 R2 g"], unfold restr_def, safe)
     subgoal using R unfolding isCommute_def gg_def restr_def rel_fun_def
     by (smt (verit, best) getRepr'_def getRepr_neper neper_getRepr_eq neper_per per_def)
     subgoal using R unfolding isCommute_def gg_def
     	 by simp (smt (verit, best) getRepr'_def getReprOn getReprOn_UNIV geterRepr_related
         neper_Some neper_getRepr_eq rel_funE)
     subgoal using R unfolding isCommute_def gg_def
     	 by simp (smt (verit, best) getRepr'_def getReprOn getReprOn_UNIV geterRepr_related
         neper_Some neper_getRepr_eq rel_funE)
     subgoal using R unfolding rel_fun_def gg_def
     	 by (smt (verit, del_insts) getRepr'_def getReprOn getReprOn_UNIV neper_getRepr_eq
        neper_per per_def)
     subgoal using R unfolding gg_def
     	 by simp (smt (verit, ccfv_SIG) getRepr'_def getRepr_neper neper_Some
        neper_getRepr_eq rel_funE) . .

lemma rel_commute_alt:
"rel_commute R1 R2 = inv_imagep (rel_fun R1 (rel_fun R1 R2)) apply_commute"
unfolding rel_commute_def inv_imagep_def restr_def fun_eq_iff by auto

thm bij_upto_transportFromRaw[OF type_definition_isCommute rel_commute_alt bij_upto_gg]

wide_typedef commute rel: rel_commute rep: "\<lambda>R1 R2. gg R1 R2 \<circ> apply_commute"
  subgoal for R1 R2 unfolding rel_commute_alt
  apply(rule neper_inv_imagep[of _ _ "Abs_commute (\<lambda>a b. SOME x. R2 x x)"])
     subgoal by simp
     subgoal unfolding rel_fun_def
     by auto (smt (verit, best) Abs_commute_inverse mem_Collect_eq neper_def someI_ex) .
  subgoal unfolding rel_commute_alt unfolding inv_imagep_def fun_eq_iff
    by (simp add: apply_commute_inject)
  subgoal using bij_upto_transportFromRaw[OF type_definition_isCommute rel_commute_alt bij_upto_gg]
    unfolding isCommute_rlt_def .
  subgoal unfolding gg_def fun_eq_iff getRepr'_def by auto .

end


(*  Title:      ZF/AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*The Axiom of Choice*}

theory AC imports Main_ZF begin

text{*This definition comes from Halmos (1960), page 59.*}
axiomatization where
  AC: "[| a \<in> A;  !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"

(*The same as AC, but no premise @{term"a \<in> A"}*)
lemma AC_Pi: "[| !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"
apply (case_tac "A=0")
apply (simp add: Pi_empty1)
(*The non-trivial case*)
apply (blast intro: AC)
done

(*Using dtac, this has the advantage of DELETING the universal quantifier*)
lemma AC_ball_Pi: "\<forall>x \<in> A. \<exists>y. y \<in> B(x) ==> \<exists>y. y \<in> Pi(A,B)"
apply (rule AC_Pi)
apply (erule bspec, assumption)
done

lemma AC_Pi_Pow: "\<exists>f. f \<in> (\<Pi> X \<in> Pow(C)-{0}. X)"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
apply (erule_tac [2] exI, blast)
done

lemma AC_func:
     "[| !!x. x \<in> A ==> (\<exists>y. y \<in> x) |] ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
prefer 2 apply (blast dest: apply_type intro: Pi_type, blast)
done

lemma non_empty_family: "[| 0 \<notin> A;  x \<in> A |] ==> \<exists>y. y \<in> x"
by (subgoal_tac "x \<noteq> 0", blast+)

lemma AC_func0: "0 \<notin> A ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule AC_func)
apply (simp_all add: non_empty_family)
done

lemma AC_func_Pow: "\<exists>f \<in> (Pow(C)-{0}) -> C. \<forall>x \<in> Pow(C)-{0}. f`x \<in> x"
apply (rule AC_func0 [THEN bexE])
apply (rule_tac [2] bexI)
prefer 2 apply assumption
apply (erule_tac [2] fun_weaken_type, blast+)
done

lemma AC_Pi0: "0 \<notin> A ==> \<exists>f. f \<in> (\<Pi> x \<in> A. x)"
apply (rule AC_Pi)
apply (simp_all add: non_empty_family)
done

end


(*  Title:      HMLSL.thy
    Author:     Sven Linker

Definition of HMLSL syntax over traffic snapshots and views for cars
with any sensors. Each formula is a function with a traffic snapshot
and view as parameters, and evaluates to True or False.
*)

section\<open>Basic HMLSL\<close>
text\<open>
In this section, we define the basic formulas of HMLSL.
All of these basic formulas and theorems are independent
of the choice of sensor function. However, they show how
the general operators (chop, changes in perspective,
atomic formulas) work.
\<close>

theory HMLSL
  imports "Restriction" "Move" Length
begin

subsection\<open>Syntax of Basic HMLSL\<close>

text \<open>
Formulas are functions associating a traffic snapshot
and a view with a Boolean value.
\<close>
type_synonym \<sigma> = " traffic \<Rightarrow> view \<Rightarrow> bool"

locale hmlsl = restriction+
  fixes sensors::"cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
  assumes sensors_ge:"(sensors e ts c) > 0"  begin
end

sublocale hmlsl<sensors
  by (simp add: sensors.intro sensors_ge)

context hmlsl
begin

text\<open>
All formulas are defined as abbreviations. As a consequence,
proofs will directly refer to the semantics of HMLSL, i.e.,
traffic snapshots and views.
\<close>

text\<open>
The first-order operators are direct translations into HOL operators.
\<close>

abbreviation mtrue  :: "\<sigma>" ("\<^bold>\<top>")
  where "\<^bold>\<top> \<equiv> \<lambda> ts w. True"
abbreviation mfalse :: "\<sigma>" ("\<^bold>\<bottom>")
  where "\<^bold>\<bottom> \<equiv> \<lambda> ts w. False"
abbreviation mnot   :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda> ts w. \<not>\<phi>(ts)(w)"
abbreviation mnegpred :: "(cars\<Rightarrow>\<sigma>)\<Rightarrow>(cars\<Rightarrow>\<sigma>)" ("\<^sup>\<not>_"[52]53)
  where "\<^sup>\<not>\<Phi> \<equiv> \<lambda>x.\<lambda> ts w. \<not>\<Phi>(x)(ts)(w)"
abbreviation mand   :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51)
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda> ts w. \<phi>(ts)(w)\<and>\<psi>(ts)(w)"
abbreviation mor    :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infix "\<^bold>\<or>"50 )
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda> ts w. \<phi>(ts)(w)\<or>\<psi>(ts)(w)"
abbreviation mimp   :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49)
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda> ts w. \<phi>(ts)(w)\<longrightarrow>\<psi>(ts)(w)"
abbreviation mequ   :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48)
  where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda> ts w. \<phi>(ts)(w)\<longleftrightarrow>\<psi>(ts)(w)"
abbreviation mforall   :: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>")
  where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda> ts w.\<forall>x. \<Phi>(x)(ts)(w)"
abbreviation mforallB  :: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<forall>"[8]9)
  where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexists   :: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>")
  where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda> ts w.\<exists>x. \<Phi>(x)(ts)(w)"
abbreviation mexistsB  :: "(('a)\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<exists>"[8]9)
  where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"
abbreviation meq    :: "'a\<Rightarrow>'a\<Rightarrow>\<sigma>" (infixr"\<^bold>="60) \<comment> \<open>Equality\<close>
  where "x\<^bold>=y \<equiv> \<lambda> ts w. x = y"
abbreviation mgeq :: "('a::ord) \<Rightarrow> 'a \<Rightarrow> \<sigma>" (infix "\<^bold>\<ge>" 60)
  where "x \<^bold>\<ge> y \<equiv> \<lambda> ts w. x \<ge> y"
abbreviation mge ::"('a::ord) \<Rightarrow> 'a \<Rightarrow> \<sigma>" (infix "\<^bold>>" 60)
  where "x \<^bold>> y \<equiv> \<lambda> ts w. x > y"

text\<open>
For the spatial modalities, we use the chopping operations
defined on views. Observe that our chop modalities are existential.
\<close>

abbreviation hchop   :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<frown>" 53)
  where "\<phi> \<^bold>\<frown> \<psi> \<equiv> \<lambda> ts w.\<exists>v u. (w=v\<parallel>u) \<and> \<phi>(ts)(v)\<and>\<psi>(ts)(u)"
abbreviation vchop   :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<smile>" 53)
  where "\<phi> \<^bold>\<smile> \<psi> \<equiv> \<lambda> ts w.\<exists>v u. (w=v--u) \<and> \<phi>(ts)(v) \<and> \<psi>(ts)(u)"
abbreviation somewhere ::"\<sigma>\<Rightarrow>\<sigma>" ( "\<^bold>\<langle>_\<^bold>\<rangle> " 55)
  where "\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<equiv> \<^bold>\<top> \<^bold>\<frown> (\<^bold>\<top>\<^bold>\<smile>\<phi> \<^bold>\<smile>\<^bold>\<top>)\<^bold>\<frown>\<^bold>\<top>"
abbreviation everywhere::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>[_\<^bold>]" 55)
  where "\<^bold>[\<phi>\<^bold>] \<equiv> \<^bold>\<not>\<^bold>\<langle>\<^bold>\<not>\<phi>\<^bold>\<rangle>"

text\<open>
To change the perspective of a view, we use
an operator in the fashion of Hybrid Logic.
\<close>
abbreviation at :: "cars \<Rightarrow> \<sigma> \<Rightarrow> \<sigma> " ("\<^bold>@ _ _" 56)
  where "\<^bold>@c \<phi> \<equiv> \<lambda>ts w .  \<forall>v'. (w=c>v') \<longrightarrow> \<phi>(ts)(v')"

text\<open>
The behavioural modalities are defined as usual modal
box-like modalities, where the accessibility relations
are given by the different types of transitions between
traffic snapshots.
\<close>

abbreviation res_box::"cars \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<box>r'(_') _" 55)
  where "\<^bold>\<box>r(c) \<phi> \<equiv> \<lambda> ts w. \<forall>ts'. (ts\<^bold>\<midarrow>r(c)\<^bold>\<rightarrow>ts') \<longrightarrow> \<phi>(ts')(w)"
abbreviation clm_box::"cars \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<box>c'(_') _" 55)
  where "\<^bold>\<box>c(c) \<phi> \<equiv> \<lambda> ts w. \<forall>ts' n. (ts\<^bold>\<midarrow>c(c,n)\<^bold>\<rightarrow>ts') \<longrightarrow> \<phi>(ts')(w)"
abbreviation wdres_box::"cars \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<box>wdr'(_') _" 55)
  where "\<^bold>\<box>wdr(c) \<phi> \<equiv> \<lambda> ts w. \<forall>ts' n. (ts\<^bold>\<midarrow>wdr(c,n)\<^bold>\<rightarrow>ts') \<longrightarrow> \<phi>(ts')(w)"
abbreviation wdclm_box::"cars \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<box>wdc'(_') _" 55)
  where "\<^bold>\<box>wdc(c) \<phi> \<equiv> \<lambda> ts w. \<forall>ts'. (ts\<^bold>\<midarrow>wdc(c)\<^bold>\<rightarrow>ts') \<longrightarrow> \<phi>(ts')(w)"
abbreviation time_box::"\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<box>\<^bold>\<tau> _" 55)
  where "\<^bold>\<box>\<^bold>\<tau> \<phi> \<equiv> \<lambda>ts w. \<forall>ts'. (ts\<^bold>\<leadsto>ts') \<longrightarrow> \<phi>(ts')(move ts ts' w)"
abbreviation globally::"\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>G _" 55)
  where "\<^bold>G \<phi> \<equiv> \<lambda>ts w. \<forall>ts'. (ts \<^bold>\<Rightarrow> ts') \<longrightarrow> \<phi>(ts')(move ts ts' w)"

text\<open>
The spatial atoms to refer to reservations, claims
and free space are direct translations of the original
definitions of MLSL \cite{Hilscher2011} into the Isabelle implementation.
\<close>

abbreviation re:: "cars \<Rightarrow> \<sigma>" ("re'(_')" 70)
  where
    "re(c) \<equiv> \<lambda> ts v. \<parallel>ext v\<parallel>> 0 \<and> len v ts c = ext v \<and>
                      restrict v (res ts) c = lan v \<and> |lan v|=1"

abbreviation cl:: "cars \<Rightarrow> \<sigma>" ("cl'(_')" 70)
  where
    "cl(c) \<equiv> \<lambda> ts v. \<parallel>ext v\<parallel>> 0 \<and> len v ts c = ext v \<and>
                      restrict v (clm ts) c = lan v \<and> |lan v| = 1"

abbreviation free:: "\<sigma>" ("free")
  where
    "free \<equiv> \<lambda> ts v. \<parallel>ext v\<parallel> > 0 \<and> |lan v| = 1 \<and>
                  (\<forall>c.  \<parallel>len v ts c\<parallel> = 0 \<or>
                    (restrict v (clm ts) c = \<emptyset> \<and> restrict v (res ts) c = \<emptyset>))"

text\<open>
Even though we do not need them for the subsequent proofs of safety,
we define ways to measure the number of lanes (width) and the
size of the extension (length) of a view. This allows us
to connect the atomic formulas for reservations and claims
with the atom denoting free space \cite{Linker2015a}.
\<close>

abbreviation width_eq::"nat \<Rightarrow> \<sigma>" ("\<^bold>\<omega> = _ " 60)
  where "\<^bold>\<omega> = n \<equiv> \<lambda>  ts v. |lan v| = n"

abbreviation width_geq::"nat \<Rightarrow> \<sigma>" ("\<^bold>\<omega> \<ge> _" 60)
  where "\<^bold>\<omega> \<ge> n \<equiv> \<lambda>  ts v. |lan v| \<ge> n"

abbreviation width_ge::"nat \<Rightarrow> \<sigma>" ("\<^bold>\<omega> > _" 60)
  where "\<^bold>\<omega> > n \<equiv> (\<^bold>\<omega> = n+1) \<^bold>\<smile> \<^bold>\<top>"

abbreviation length_eq::"real \<Rightarrow> \<sigma>" ("\<^bold>\<l> = _ " 60)
  where "\<^bold>\<l> = r \<equiv> \<lambda> ts v. \<parallel>ext v\<parallel> = r"

abbreviation length_ge:: "real \<Rightarrow> \<sigma>" ("\<^bold>\<l> > _" 60)
  where "\<^bold>\<l> > r \<equiv> \<lambda> ts v. \<parallel>ext v\<parallel> > r"

abbreviation length_geq::"real \<Rightarrow> \<sigma>" ("\<^bold>\<l> \<ge> _" 60)
  where "\<^bold>\<l> \<ge> r \<equiv> (\<^bold>\<l> = r) \<^bold>\<or> (\<^bold>\<l> > r)"

text\<open>
For convenience, we use abbreviations for
the validity and satisfiability of formulas. While
the former gives a nice way to express theorems,
the latter is useful within proofs.
\<close>

abbreviation valid :: "\<sigma> \<Rightarrow> bool" ("\<Turnstile> _" 10 )
  where "\<Turnstile> \<phi> \<equiv>  \<forall>ts. \<forall>v. \<phi>(ts)(v)"

abbreviation satisfies::" traffic \<Rightarrow> view \<Rightarrow> \<sigma> \<Rightarrow> bool" ("_ , _ \<Turnstile> _" 10)
  where "ts,v \<Turnstile> \<phi> \<equiv> \<phi>(ts)(v)"

subsection \<open>Theorems about Basic HMLSL\<close>

lemma hchop_weaken1: " \<Turnstile> \<phi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<frown> \<^bold>\<top>) "
  using horizontal_chop_empty_right  by fastforce

lemma hchop_weaken2: " \<Turnstile> \<phi> \<^bold>\<rightarrow> (\<^bold>\<top> \<^bold>\<frown> \<phi>) "
  using horizontal_chop_empty_left  by fastforce

lemma hchop_weaken: " \<Turnstile> \<phi> \<^bold>\<rightarrow> (\<^bold>\<top> \<^bold>\<frown> \<phi> \<^bold>\<frown> \<^bold>\<top>)"
  using hchop_weaken1 hchop_weaken2  by metis

lemma hchop_neg1:"\<Turnstile> \<^bold>\<not> (\<phi> \<^bold>\<frown> \<^bold>\<top>) \<^bold>\<rightarrow> ((\<^bold>\<not> \<phi>) \<^bold>\<frown> \<^bold>\<top>)"
  using horizontal_chop1  by fastforce

lemma hchop_neg2:"\<Turnstile> \<^bold>\<not> (\<^bold>\<top>\<^bold>\<frown>\<phi> ) \<^bold>\<rightarrow> (\<^bold>\<top> \<^bold>\<frown> \<^bold>\<not> \<phi>)"
  using horizontal_chop1  by fastforce

lemma hchop_disj_distr1:"\<Turnstile> ((\<phi> \<^bold>\<frown> (\<psi> \<^bold>\<or> \<chi>)) \<^bold>\<leftrightarrow> ((\<phi> \<^bold>\<frown> \<psi>)\<^bold>\<or>(\<phi> \<^bold>\<frown> \<chi>)))"
  by blast

lemma hchop_disj_distr2:"\<Turnstile> (((\<psi> \<^bold>\<or> \<chi>)\<^bold>\<frown>\<phi>) \<^bold>\<leftrightarrow> ((\<psi> \<^bold>\<frown> \<phi>)\<^bold>\<or>(\<chi> \<^bold>\<frown> \<phi>)))"
  by blast

lemma hchop_assoc:"\<Turnstile>\<phi> \<^bold>\<frown> (\<psi> \<^bold>\<frown> \<chi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<frown> \<psi>) \<^bold>\<frown> \<chi>"
  using horizontal_chop_assoc1 horizontal_chop_assoc2  by fastforce

lemma v_chop_weaken1:"\<Turnstile> (\<phi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<smile> \<^bold>\<top>))"
  using vertical_chop_empty_down  by fastforce

lemma v_chop_weaken2:"\<Turnstile> (\<phi> \<^bold>\<rightarrow> (\<^bold>\<top> \<^bold>\<smile> \<phi>))"
  using vertical_chop_empty_up  by fastforce

lemma v_chop_assoc:"\<Turnstile>(\<phi> \<^bold>\<smile> (\<psi> \<^bold>\<smile> \<chi>)) \<^bold>\<leftrightarrow> ((\<phi> \<^bold>\<smile> \<psi>) \<^bold>\<smile> \<chi>)"
  using vertical_chop_assoc1 vertical_chop_assoc2  by fastforce

lemma vchop_disj_distr1:"\<Turnstile> ((\<phi> \<^bold>\<smile> (\<psi> \<^bold>\<or> \<chi>)) \<^bold>\<leftrightarrow> ((\<phi> \<^bold>\<smile> \<psi>)\<^bold>\<or>(\<phi> \<^bold>\<smile> \<chi>)))"
  by blast

lemma vchop_disj_distr2:"\<Turnstile> (((\<psi> \<^bold>\<or> \<chi>) \<^bold>\<smile> \<phi> ) \<^bold>\<leftrightarrow> ((\<psi> \<^bold>\<smile> \<phi>)\<^bold>\<or>(\<chi> \<^bold>\<smile> \<phi>)))"
  by blast

lemma at_exists :"\<Turnstile> \<phi> \<^bold>\<rightarrow> (\<^bold>\<exists> c. \<^bold>@c \<phi>)"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>\<phi>"
  obtain d where d_def:"d=own v" by blast
  then have "ts,v \<Turnstile> \<^bold>@d \<phi>" using assm switch_refl switch_unique  by fastforce
  thus "ts,v \<Turnstile> (\<^bold>\<exists> c. \<^bold>@c \<phi>)" ..
qed

lemma at_conj_distr:"\<Turnstile>(\<^bold>@c ( \<phi> \<^bold>\<and> \<psi>)) \<^bold>\<leftrightarrow> ((\<^bold>@c \<phi>) \<^bold>\<and> (\<^bold>@c \<psi>))"
  using switch_unique by blast

lemma at_disj_dist:"\<Turnstile>(\<^bold>@c (\<phi> \<^bold>\<or> \<psi>)) \<^bold>\<leftrightarrow> ((\<^bold>@c \<phi> )  \<^bold>\<or> ( \<^bold>@c \<psi> ))"
  using switch_unique  by fastforce

lemma at_hchop_dist1:"\<Turnstile>(\<^bold>@c (\<phi> \<^bold>\<frown> \<psi>)) \<^bold>\<rightarrow> ((\<^bold>@c \<phi>) \<^bold>\<frown> (\<^bold>@c \<psi>))"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts, v \<Turnstile>(\<^bold>@c (\<phi> \<^bold>\<frown> \<psi>))"
  obtain v' where v':"v=c>v'" using switch_always_exists  by fastforce
  with assm obtain v1' and v2'
    where chop:"(v'=v1'\<parallel>v2') \<and> (ts,v1' \<Turnstile> \<phi>) \<and> (ts,v2'\<Turnstile>\<psi>)"
    by blast
  from chop and v' obtain v1 and v2
    where origin:"(v1=c>v1') \<and> (v2=c>v2') \<and> (v=v1\<parallel>v2)"
    using switch_hchop2  by fastforce
  hence v1:"ts,v1 \<Turnstile> (\<^bold>@c \<phi>)" and v2:"ts,v2 \<Turnstile> (\<^bold>@c \<psi>)"
    using switch_unique chop by fastforce+
  from v1 and v2 and origin show "ts,v \<Turnstile>(\<^bold>@c \<phi>) \<^bold>\<frown> (\<^bold>@c \<psi>)" by blast
qed

lemma at_hchop_dist2:"\<Turnstile>( (\<^bold>@c \<phi>) \<^bold>\<frown> (\<^bold>@c \<psi>)) \<^bold>\<rightarrow> (\<^bold>@c (\<phi> \<^bold>\<frown> \<psi>))  "
  using switch_unique switch_hchop1 switch_def   by metis

lemma at_hchop_dist:"\<Turnstile>( (\<^bold>@c \<phi>) \<^bold>\<frown>  (\<^bold>@c \<psi>)) \<^bold>\<leftrightarrow> (\<^bold>@c (\<phi> \<^bold>\<frown> \<psi>))  "
  using at_hchop_dist1 at_hchop_dist2 by blast

lemma at_vchop_dist1:"\<Turnstile>(\<^bold>@c (\<phi> \<^bold>\<smile> \<psi>)) \<^bold>\<rightarrow> ( (\<^bold>@c \<phi>) \<^bold>\<smile> (\<^bold>@c \<psi>))"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts, v \<Turnstile>(\<^bold>@c (\<phi> \<^bold>\<smile> \<psi>))"
  obtain v' where v':"v=c>v'" using switch_always_exists by fastforce
  with assm obtain v1' and v2'
    where chop:"(v'=v1'--v2') \<and> (ts,v1' \<Turnstile> \<phi>) \<and> (ts,v2'\<Turnstile>\<psi>)"
    by blast
  from chop and v' obtain v1 and v2
    where origin:"(v1=c>v1') \<and> (v2=c>v2') \<and> (v=v1--v2)"
    using switch_vchop2 by fastforce
  hence v1:"ts,v1 \<Turnstile> (\<^bold>@c \<phi>)" and v2:"ts,v2 \<Turnstile> (\<^bold>@c \<psi>)"
    using switch_unique chop by fastforce+
  from v1 and v2 and origin show "ts,v \<Turnstile> (\<^bold>@c \<phi>) \<^bold>\<smile> (\<^bold>@c \<psi>)" by blast
qed

lemma at_vchop_dist2:"\<Turnstile>( (\<^bold>@c \<phi>) \<^bold>\<smile> (\<^bold>@c \<psi>)) \<^bold>\<rightarrow> (\<^bold>@c (\<phi> \<^bold>\<smile> \<psi>))  "
  using switch_unique switch_vchop1 switch_def   by metis

lemma at_vchop_dist:"\<Turnstile>( (\<^bold>@c \<phi>) \<^bold>\<smile> (\<^bold>@c \<psi>)) \<^bold>\<leftrightarrow> (\<^bold>@c (\<phi> \<^bold>\<smile> \<psi>))  "
  using at_vchop_dist1 at_vchop_dist2 by blast

lemma at_eq:"\<Turnstile>(\<^bold>@e c \<^bold>= d) \<^bold>\<leftrightarrow> (c \<^bold>= d)"
  using switch_always_exists  by (metis )

lemma at_neg1:"\<Turnstile>(\<^bold>@c \<^bold>\<not> \<phi>) \<^bold>\<rightarrow> \<^bold>\<not> (\<^bold>@c \<phi>)"
  using switch_unique
  by (metis select_convs switch_def)

lemma at_neg2:"\<Turnstile>\<^bold>\<not> (\<^bold>@c \<phi> ) \<^bold>\<rightarrow> ( (\<^bold>@c \<^bold>\<not> \<phi>))"
  using switch_unique  by fastforce

lemma at_neg :"\<Turnstile>(\<^bold>@c( \<^bold>\<not> \<phi>)) \<^bold>\<leftrightarrow> \<^bold>\<not> (\<^bold>@c \<phi>)"
  using at_neg1 at_neg2 by metis

lemma at_neg':"ts,v \<Turnstile> \<^bold>\<not> (\<^bold>@c \<phi>) \<^bold>\<leftrightarrow> (\<^bold>@c( \<^bold>\<not> \<phi>))" using at_neg by simp

lemma at_neg_neg1:"\<Turnstile>(\<^bold>@c \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>@c \<^bold>\<not> \<phi>)"
  using switch_unique switch_def switch_refl
  by (metis select_convs switch_def)

lemma at_neg_neg2:"\<Turnstile>\<^bold>\<not>(\<^bold>@c \<^bold>\<not> \<phi>) \<^bold>\<rightarrow> (\<^bold>@c  \<phi>)"
  using switch_unique switch_def switch_refl
  by metis

lemma at_neg_neg:"\<Turnstile> (\<^bold>@c \<phi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<^bold>@c \<^bold>\<not> \<phi>)"
  using at_neg_neg1 at_neg_neg2 by metis

lemma globally_all_iff:"\<Turnstile> (\<^bold>G(\<^bold>\<forall>c. \<phi>)) \<^bold>\<leftrightarrow> (\<^bold>\<forall>c.( \<^bold>G \<phi>))" by simp
lemma globally_all_iff':"ts,v\<Turnstile> (\<^bold>G(\<^bold>\<forall>c. \<phi>)) \<^bold>\<leftrightarrow> (\<^bold>\<forall>c.( \<^bold>G \<phi>))" by simp

lemma globally_refl:" \<Turnstile>(\<^bold>G \<phi>) \<^bold>\<rightarrow> \<phi>"
  using traffic.abstract.refl traffic.move_nothing  by fastforce

lemma globally_4: "\<Turnstile> (\<^bold>G  \<phi>) \<^bold>\<rightarrow> \<^bold>G \<^bold>G \<phi>"
proof (rule allI|rule impI)+
  fix ts v ts' ts''
  assume 1:"ts \<^bold>\<Rightarrow> ts'" and 2:"ts' \<^bold>\<Rightarrow> ts''" and 3:"ts,v \<Turnstile> \<^bold>G \<phi>"
  from 2 and 1 have "ts \<^bold>\<Rightarrow> ts''" using traffic.abs_trans by blast
  moreover from 1 and 2 have "move ts' ts'' (move ts ts' v) = move ts ts'' v"
    using traffic.move_trans by blast
  with 3 show "ts'', move ts' ts'' (move ts ts' v)  \<Turnstile>\<phi>" using calculation by simp
qed

lemma spatial_weaken: "\<Turnstile> (\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<phi>\<^bold>\<rangle>)"
  using horizontal_chop_empty_left horizontal_chop_empty_right vertical_chop_empty_down
    vertical_chop_empty_up
  by fastforce

lemma spatial_weaken2:"\<Turnstile> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> (\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)"
  using spatial_weaken horizontal_chop_empty_left horizontal_chop_empty_right
    vertical_chop_empty_down vertical_chop_empty_up
  by blast

lemma somewhere_distr: "\<Turnstile> \<^bold>\<langle>\<phi>\<^bold>\<or>\<psi>\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<^bold>\<or> \<^bold>\<langle>\<psi>\<^bold>\<rangle>"
  by blast

lemma somewhere_and:"\<Turnstile> \<^bold>\<langle>\<phi> \<^bold>\<and> \<psi>\<^bold>\<rangle> \<^bold>\<rightarrow>  \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<langle>\<psi>\<^bold>\<rangle>"
  by blast

lemma somewhere_and_or_distr :"\<Turnstile>(\<^bold>\<langle> \<chi> \<^bold>\<and> (\<phi> \<^bold>\<or> \<psi>) \<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>\<langle> \<chi> \<^bold>\<and>  \<phi> \<^bold>\<rangle> \<^bold>\<or> \<^bold>\<langle> \<chi> \<^bold>\<and> \<psi> \<^bold>\<rangle>)"
  by blast

lemma width_add1:"\<Turnstile>((\<^bold>\<omega> = x) \<^bold>\<smile> (\<^bold>\<omega> = y) \<^bold>\<rightarrow> \<^bold>\<omega> = x+y)"
  using vertical_chop_add1  by fastforce

lemma width_add2:"\<Turnstile>((\<^bold>\<omega> = x+y) \<^bold>\<rightarrow>  (\<^bold>\<omega> = x) \<^bold>\<smile> \<^bold>\<omega> = y)"
  using vertical_chop_add2  by fastforce

lemma width_hchop_stable: "\<Turnstile>((\<^bold>\<omega> = x) \<^bold>\<leftrightarrow> ((\<^bold>\<omega> = x) \<^bold>\<frown> (\<^bold>\<omega>=x)))"
  using hchop_def horizontal_chop1
  by force

lemma length_geq_zero:"\<Turnstile> (\<^bold>\<l> \<ge> 0)"
  by (metis order.not_eq_order_implies_strict real_int.length_ge_zero)

lemma length_split: "\<Turnstile>((\<^bold>\<l> > 0) \<^bold>\<rightarrow> (\<^bold>\<l> > 0) \<^bold>\<frown> (\<^bold>\<l> > 0))"
  using horizontal_chop_non_empty  by fastforce

lemma length_meld: "\<Turnstile>((\<^bold>\<l> > 0) \<^bold>\<frown> (\<^bold>\<l> > 0) \<^bold>\<rightarrow> (\<^bold>\<l> > 0))"
  using hchop_def real_int.chop_add_length_ge_0
  by (metis (no_types, lifting))

lemma length_dense:"\<Turnstile>((\<^bold>\<l> > 0) \<^bold>\<leftrightarrow> (\<^bold>\<l> > 0) \<^bold>\<frown> (\<^bold>\<l> > 0))"
  using length_meld length_split by blast

lemma length_add1:"\<Turnstile>((\<^bold>\<l>=x) \<^bold>\<frown> (\<^bold>\<l>= y)) \<^bold>\<rightarrow> (\<^bold>\<l>= x+y)"
  using hchop_def real_int.rchop_def real_int.length_def   by fastforce

lemma length_add2:"\<Turnstile> (x \<^bold>\<ge> 0 \<^bold>\<and> y \<^bold>\<ge> 0) \<^bold>\<rightarrow> ( (\<^bold>\<l>=x+y) \<^bold>\<rightarrow> ((\<^bold>\<l>=x) \<^bold>\<frown> (\<^bold>\<l>=y)))"
  using horizontal_chop_split_add  by fastforce

lemma length_add:"\<Turnstile> (x \<^bold>\<ge> 0 \<^bold>\<and> y \<^bold>\<ge> 0) \<^bold>\<rightarrow> ( (\<^bold>\<l>=x+y) \<^bold>\<leftrightarrow> ((\<^bold>\<l>=x) \<^bold>\<frown> (\<^bold>\<l>=y)))"
  using length_add1 length_add2 by blast

lemma length_vchop_stable:"\<Turnstile>(\<^bold>\<l> = x) \<^bold>\<leftrightarrow> ((\<^bold>\<l> = x) \<^bold>\<smile> ( \<^bold>\<l> = x))"
  using vchop_def vertical_chop1  by fastforce

lemma res_ge_zero:"\<Turnstile>(re(c) \<^bold>\<rightarrow> \<^bold>\<l>>0)"
  by blast

lemma clm_ge_zero:"\<Turnstile>(cl(c) \<^bold>\<rightarrow> \<^bold>\<l>>0)"
  by blast

lemma free_ge_zero:"\<Turnstile>free \<^bold>\<rightarrow> \<^bold>\<l>>0"
  by blast

lemma width_res:"\<Turnstile>(re(c) \<^bold>\<rightarrow> \<^bold>\<omega> = 1)"
  by auto

lemma width_clm:"\<Turnstile>(cl(c) \<^bold>\<rightarrow> \<^bold>\<omega> = 1)"
  by simp

lemma width_free:"\<Turnstile>(free \<^bold>\<rightarrow> \<^bold>\<omega> = 1)"
  by simp

lemma width_somewhere_res:"\<Turnstile> \<^bold>\<langle>re(c)\<^bold>\<rangle> \<^bold>\<rightarrow> (\<^bold>\<omega> \<ge> 1)"
proof (rule allI|rule impI)+
  fix ts v
  assume "ts,v \<Turnstile>  \<^bold>\<langle>re(c)\<^bold>\<rangle>"
  then show "ts,v \<Turnstile> (\<^bold>\<omega> \<ge> 1)"
    using view.hchop_def view.vertical_chop_width_mon by fastforce
qed

lemma clm_disj_res:"\<Turnstile> \<^bold>\<not> \<^bold>\<langle> cl(c) \<^bold>\<and> re(c) \<^bold>\<rangle>"
proof (rule allI|rule notI)+
  fix ts v
  assume "ts,v \<Turnstile>\<^bold>\<langle>cl(c) \<^bold>\<and> re(c)\<^bold>\<rangle>"
  then obtain v' where "v' \<le> v \<and> (ts,v' \<Turnstile> cl(c) \<^bold>\<and> re(c))"
    by (meson view.somewhere_leq)
  then show False using disjoint
    by (metis card_non_empty_geq_one inf.idem restriction.restriction_clm_leq_one
        restriction.restriction_clm_res_disjoint)
qed

lemma width_ge:"\<Turnstile> (\<^bold>\<omega>> 0) \<^bold>\<rightarrow> (\<^bold>\<exists> x. (\<^bold>\<omega> = x) \<^bold>\<and> (x \<^bold>> 0))"
  using  vertical_chop_add1  add_gr_0 zero_less_one  by auto

lemma two_res_width: "\<Turnstile>((re(c) \<^bold>\<smile> re(c)) \<^bold>\<rightarrow> \<^bold>\<omega> = 2)"
  by (metis one_add_one width_add1)

lemma res_at_most_two:"\<Turnstile>\<^bold>\<not> (re(c) \<^bold>\<smile>  re(c)  \<^bold>\<smile>  re(c) )"
proof(rule allI| rule notI )+
  fix ts v
  assume "ts, v \<Turnstile> (re(c) \<^bold>\<smile>  re(c)  \<^bold>\<smile>  re(c) )"
  then obtain v' and v1 and v2 and v3
    where "v = v1--v'" and "v'=v2--v3"
    and "ts,v1 \<Turnstile>re(c)" and "ts,v2 \<Turnstile>re(c)" and "ts,v3 \<Turnstile>re(c)"
    by blast
  then show False
  proof -
    have "|restrict v' (res ts) c| < |restrict v (res ts) c|"
      using \<open>ts,v1 \<Turnstile>re(c)\<close> \<open>v=v1--v'\<close> restriction.restriction_add_res by auto
    then show ?thesis
      by (metis (no_types) \<open>ts,v2 \<Turnstile> re(c)\<close> \<open>ts,v3 \<Turnstile>re(c)\<close> \<open>v'=v2--v3\<close> not_less
          one_add_one restriction_add_res restriction_res_leq_two)
  qed
qed

lemma res_at_most_two2:"\<Turnstile>\<^bold>\<not> \<^bold>\<langle>re(c) \<^bold>\<smile>  re(c)  \<^bold>\<smile>  re(c)\<^bold>\<rangle>"
  using res_at_most_two by blast

lemma res_at_most_somewhere:"\<Turnstile>\<^bold>\<not> \<^bold>\<langle>re(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>re(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>re(c)\<^bold>\<rangle> "
proof (rule allI|rule notI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>  (\<^bold>\<langle>re(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>re(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>re(c)\<^bold>\<rangle> )"
  obtain vu and v1 and vm and vd
    where chops:"(v=vu--v1) \<and> (v1 = vm--vd)\<and> (ts,vu \<Turnstile>\<^bold>\<langle>re(c)\<^bold>\<rangle>)
                 \<and> (ts,vm \<Turnstile> \<^bold>\<langle>re(c)\<^bold>\<rangle> ) \<and>( ts,vd \<Turnstile> \<^bold>\<langle> re(c)\<^bold>\<rangle>)"
    using assm by blast
  from chops have res_vu:"|restrict vu (res ts) c| \<ge> 1"
    by (metis restriction_card_somewhere_mon)
  from chops have res_vm:"|restrict vm (res ts) c| \<ge> 1"
    by (metis restriction_card_somewhere_mon)
  from chops have res_vd:"|restrict vd (res ts) c| \<ge> 1"
    by (metis restriction_card_somewhere_mon)
  from chops have
    "|restrict v (res ts) c | =
     |restrict vu (res ts) c|+ |restrict vm (res ts) c| + |restrict vd (res ts) c| "
    using restriction_add_res by force
  with res_vu and res_vd res_vm have "|restrict v (res ts) c | \<ge> 3"
    by linarith
  with restriction_res_leq_two show False
    by (metis not_less_eq_eq numeral_2_eq_2 numeral_3_eq_3)
qed

lemma res_adj:"\<Turnstile>\<^bold>\<not>  (re(c) \<^bold>\<smile> (\<^bold>\<omega> > 0) \<^bold>\<smile> re(c)) "
proof (rule allI|rule notI)+
  fix ts v
  assume "ts,v \<Turnstile> (re(c) \<^bold>\<smile> (\<^bold>\<omega> > 0) \<^bold>\<smile> re(c)) "
  then obtain v1 and v' and v2 and vn
    where chop:"(v=v1--v') \<and> (v'=vn--v2) \<and> (ts,v1\<Turnstile>re(c))
                \<and> (ts,vn \<Turnstile> \<^bold>\<omega> > 0) \<and> (ts,v2\<Turnstile>re(c))"
    by blast
  hence res1:"|restrict v1 (res ts) c| \<ge> 1" by (simp add: le_numeral_extra(4))
  from chop have res2: "|restrict v2 (res ts) c| \<ge> 1" by (simp add: le_numeral_extra(4))
  from res1 and res2 have "|restrict v (res ts) c| \<ge> 2"
    using chop restriction.restriction_add_res by auto
  then have resv:"|restrict v (res ts) c| = 2"
    using dual_order.antisym restriction.restriction_res_leq_two by blast
  hence res_two_lanes:"|res ts c| =2" using atMostTwoRes restrict_res
    by (metis (no_types, lifting) nat_int.card_subset_le dual_order.antisym)
  from this obtain p where p_def:"Rep_nat_int (res ts c) = {p, p+1}"
    using consecutiveRes by force
  have "Abs_nat_int {p,p+1} \<sqsubseteq> lan v"
    by (metis Rep_nat_int_inverse atMostTwoRes card_seteq finite_atLeastAtMost
        insert_not_empty nat_int.card'.rep_eq nat_int.card_seq less_eq_nat_int.rep_eq
        p_def resv restrict_res restrict_view)
  have vn_not_e:"lan vn \<noteq> \<emptyset>" using chop
    by (metis nat_int.card_empty_zero less_irrefl width_ge)
  hence consec_vn_v2:"nat_int.consec (lan vn) (lan v2)"
    using nat_int.card_empty_zero chop nat_int.nchop_def one_neq_zero vchop_def
    by auto
  have v'_not_e:"lan v' \<noteq> \<emptyset>" using chop
    by (metis less_irrefl nat_int.card_empty_zero view.vertical_chop_assoc2 width_ge)
  hence consec_v1_v':"nat_int.consec (lan v1) (lan v')"
    by (metis (no_types, lifting) nat_int.card_empty_zero chop nat_int.nchop_def
        one_neq_zero vchop_def)
  hence consec_v1_vn:"nat_int.consec (lan v1) (lan vn)"
    by (metis (no_types, lifting) chop consec_vn_v2 nat_int.consec_def
        nat_int.chop_min vchop_def)
  hence lesser_con:"\<forall>n m. (n \<^bold>\<in> (lan v1) \<and> m \<^bold>\<in> (lan v2) \<longrightarrow> n < m)"
    using consec_v1_vn consec_vn_v2 nat_int.consec_trans_lesser
    by auto
  have p_in_v1:"p \<^bold>\<in> lan v1"
  proof (rule ccontr)
    assume "\<not> p \<^bold>\<in> lan v1"
    then have "p \<^bold>\<notin> lan v1" by (simp )
    hence "p \<^bold>\<notin> restrict v1 (res ts) c"  using chop  by (simp add: chop )
    then have "p+1 \<^bold>\<in> restrict v1 (res ts) c"
    proof -
       have "{p, p + 1} \<inter> (Rep_nat_int (res ts c) \<inter> Rep_nat_int (lan v1)) \<noteq> {}"
         by (metis chop Rep_nat_int_inject bot_nat_int.rep_eq consec_v1_v'
             inf_nat_int.rep_eq nat_int.consec_def p_def restriction.restrict_def)
      then have "p + 1 \<in> Rep_nat_int (lan v1)"
        using \<open>p \<^bold>\<notin> restrict v1 (res ts) c\<close> inf_nat_int.rep_eq not_in.rep_eq
          restriction.restrict_def by force
      then show ?thesis
        using chop el.rep_eq by presburger
    qed
    hence suc_p:"p+1 \<^bold>\<in> lan v1" using chop by (simp add: chop)
    hence "p+1 \<^bold>\<notin> lan v2" using p_def restrict_def using lesser_con nat_int.el.rep_eq
        nat_int.not_in.rep_eq by auto
    then have "p \<^bold>\<in> restrict v2 (res ts) c"
    proof -
      have f1: "minimum (lan v2) \<in> Rep_nat_int (lan v2)"
        using consec_vn_v2 el.rep_eq minimum_in nat_int.consec_def by simp
      have "lan v2 \<sqsubseteq> res ts c"
        by (metis (no_types) chop restriction.restrict_res)
      then have "minimum (lan v2) = p"
        using \<open>p + 1 \<^bold>\<notin> lan v2\<close> f1 less_eq_nat_int.rep_eq not_in.rep_eq p_def by auto
      then show ?thesis
        using f1 by (metis chop el.rep_eq)
    qed
    hence p:"p \<^bold>\<in> lan v2" using p_def restrict_def
      using chop by auto
    show False using lesser_con suc_p p by blast
  qed
  hence p_not_in_v2:"p \<^bold>\<notin> lan v2" using p_def restrict_def lesser_con
      nat_int.el.rep_eq nat_int.not_in.rep_eq
    by auto
  then have "p+1 \<^bold>\<in> restrict v2 (res ts) c"
  proof -
    have f1: "minimum (lan v2) \<^bold>\<in> lan v2"
      using consec_vn_v2 minimum_in nat_int.consec_def by simp
    obtain x where mini:"x = minimum (lan v2)" by blast
    have "x = p + 1"
      by (metis IntD1 p_not_in_v2  chop el.rep_eq f1 inf_nat_int.rep_eq insertE mini
          not_in.rep_eq p_def restriction.restrict_def singletonD)
    then show ?thesis
      using chop f1 mini by auto
  qed
  hence suc_p_in_v2:"p+1 \<^bold>\<in> lan v2" using p_def restrict_def using chop by auto
  have "\<forall>n m. (n \<^bold>\<in> (lan v1) \<and> m \<^bold>\<in> (lan vn) \<longrightarrow> n < m)"
    using consec_v1_vn nat_int.consec_lesser by auto
  with p_in_v1 have ge_p:"\<forall>m. (m \<^bold>\<in> lan vn \<longrightarrow> p < m)"
    by blast
  have "\<forall>n m. (n \<^bold>\<in> (lan vn) \<and> m \<^bold>\<in> (lan v2) \<longrightarrow> n < m)"
    using consec_vn_v2 nat_int.consec_lesser by auto
  with suc_p_in_v2 have less_suc_p:"\<forall>m. (m \<^bold>\<in> lan vn \<longrightarrow>  m< p+1)"
    by blast
  have "\<forall>m. (m \<^bold>\<in> lan vn \<longrightarrow>  (m< p+1 \<and> m > p) )"
    using ge_p less_suc_p by auto
  hence "\<not>(\<exists>m. (m \<^bold>\<in> lan vn))"
    by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right linorder_not_less)
  hence "lan vn = \<emptyset>" using nat_int.non_empty_elem_in by auto
  with vn_not_e show False by blast
qed

lemma clm_sing:"\<Turnstile>\<^bold>\<not>  (cl(c) \<^bold>\<smile> cl(c)) "
  using atMostOneClm  restriction_add_clm vchop_def restriction_clm_leq_one
  by (metis (no_types, hide_lams) add_eq_self_zero le_add1 le_antisym one_neq_zero)

lemma clm_sing_somewhere:"\<Turnstile>\<^bold>\<not>  \<^bold>\<langle>cl(c) \<^bold>\<smile> cl(c)\<^bold>\<rangle> "
  using clm_sing by blast

lemma clm_sing_not_interrupted:"\<Turnstile> \<^bold>\<not>(cl(c) \<^bold>\<smile> \<^bold>\<top> \<^bold>\<smile> cl(c))"
  using atMostOneClm  restriction_add_clm vchop_def restriction_clm_leq_one clm_sing
  by (metis (no_types, hide_lams) add.commute add_eq_self_zero dual_order.antisym
      le_add1 one_neq_zero)

lemma clm_sing_somewhere2:"\<Turnstile>\<^bold>\<not>  (\<^bold>\<top> \<^bold>\<smile> cl(c) \<^bold>\<smile> \<^bold>\<top> \<^bold>\<smile>  cl(c) \<^bold>\<smile> \<^bold>\<top>) "
  using clm_sing_not_interrupted vertical_chop_assoc1
  by meson

lemma clm_sing_somewhere3:"\<Turnstile>\<^bold>\<not>  \<^bold>\<langle>(\<^bold>\<top> \<^bold>\<smile> cl(c) \<^bold>\<smile> \<^bold>\<top> \<^bold>\<smile>  cl(c) \<^bold>\<smile> \<^bold>\<top>)\<^bold>\<rangle> "
  by (meson clm_sing_not_interrupted view.vertical_chop_assoc1)

lemma clm_at_most_somewhere:"\<Turnstile>\<^bold>\<not> (\<^bold>\<langle>cl(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>cl(c)\<^bold>\<rangle>)"
proof (rule allI| rule notI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>  (\<^bold>\<langle>cl(c)\<^bold>\<rangle> \<^bold>\<smile> \<^bold>\<langle>cl(c)\<^bold>\<rangle>)"
  obtain vu and vd
    where chops:"(v=vu--vd)\<and> (ts,vu \<Turnstile>\<^bold>\<langle>cl(c)\<^bold>\<rangle>) \<and> ( ts,vd \<Turnstile> \<^bold>\<langle> cl(c)\<^bold>\<rangle>)"
    using assm by blast
  from chops have clm_vu:"|restrict vu (clm ts) c| \<ge> 1"
    by (metis restriction_card_somewhere_mon)
  from chops have clm_vd:"|restrict vd (clm ts) c| \<ge> 1"
    by (metis restriction_card_somewhere_mon)
  from chops have clm_add:
    "|restrict v (clm ts) c | = |restrict vu (clm ts) c| + |restrict vd (clm ts) c|"
    using restriction_add_clm      by auto
  with clm_vu and clm_vd have "|restrict v (clm ts) c | \<ge> 2"
    using add.commute add_eq_self_zero dual_order.antisym le_add1 less_one not_le
      restriction_res_leq_two
    by linarith
  with restriction_clm_leq_one show False
    by (metis One_nat_def not_less_eq_eq numeral_2_eq_2)
qed

lemma res_decompose: "\<Turnstile>(re(c)  \<^bold>\<rightarrow> re(c) \<^bold>\<frown> re(c))"
proof (rule allI| rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>re(c)"
  then obtain v1 and v2
    where 1:"v=v1\<parallel>v2" and 2:"\<parallel>ext v1\<parallel> > 0" and 3:"\<parallel>ext v2\<parallel> > 0"
    using  view.horizontal_chop_non_empty by blast
  then have 4:"|lan v1| = 1" and 5:"|lan v2| = 1"
    using assm view.hchop_def by auto
  then have 6:"ts,v1 \<Turnstile>re(c)"
    by (metis 2 1  assm len_view_hchop_left  restriction.restrict_eq_lan_subs
        restriction.restrict_view restriction.restriction_stable1)
  from 5 have 7:"ts,v2 \<Turnstile>re(c)"
    by (metis "1" "3" "6" assm len_view_hchop_right restriction.restrict_eq_lan_subs
        restriction.restrict_view restriction.restriction_stable)
  from 1 and 6 and 7 show "ts,v \<Turnstile>re(c) \<^bold>\<frown> re(c)" by blast
qed

lemma res_compose: "\<Turnstile>(re(c) \<^bold>\<frown> re(c)  \<^bold>\<rightarrow> re(c))"
  using  real_int.chop_dense len_compose_hchop hchop_def length_dense restrict_def
  by (metis (no_types, lifting))

lemma res_dense:"\<Turnstile>re(c) \<^bold>\<leftrightarrow> re(c) \<^bold>\<frown> re(c)"
  using res_decompose res_compose by blast

lemma res_continuous :"\<Turnstile>(re(c)) \<^bold>\<rightarrow> (\<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown> ( \<^bold>\<not>re(c) \<^bold>\<and> \<^bold>\<l> > 0) \<^bold>\<frown> \<^bold>\<top>))"
  by (metis (no_types, lifting) hchop_def len_view_hchop_left len_view_hchop_right
      restrict_def)

lemma no_clm_before_res:"\<Turnstile>\<^bold>\<not>(cl(c) \<^bold>\<frown> re(c))"
  by (metis (no_types, lifting) nat_int.card_empty_zero nat_int.card_subset_le
      disjoint hchop_def inf_assoc inf_le1 not_one_le_zero restrict_def)

lemma no_clm_before_res2:"\<Turnstile>\<^bold>\<not> (cl(c) \<^bold>\<frown> \<^bold>\<top> \<^bold>\<frown> re(c))"
proof (rule ccontr)
  assume "\<not> (\<Turnstile> \<^bold>\<not> (cl(c) \<^bold>\<frown> \<^bold>\<top> \<^bold>\<frown> re(c)))"
  then obtain ts and v where assm:"ts,v \<Turnstile> (cl(c) \<^bold>\<frown> \<^bold>\<top> \<^bold>\<frown> re(c))" by blast
  then have clm_subs:"restrict v (clm ts) c = restrict v (res ts) c"
    using restriction_stable
    by (metis (no_types, lifting) hchop_def restrict_def)
  have "restrict v (clm ts )c \<noteq> \<emptyset>"
    using assm nat_int.card_non_empty_geq_one restriction_stable1
    by auto
  then have res_in_neq:"restrict v (clm ts) c \<sqinter> restrict v (res ts) c \<noteq>\<emptyset>"
    using clm_subs inf_absorb1
    by (simp )
  then show False using restriction_clm_res_disjoint
    by (metis inf_commute restriction.restriction_clm_res_disjoint)
qed

lemma clm_decompose: "\<Turnstile>(cl(c)  \<^bold>\<rightarrow> cl(c) \<^bold>\<frown> cl(c))"
proof (rule allI|rule impI)+
  fix ts v
  assume assm: "ts,v \<Turnstile> cl(c)"
  have restr:"restrict v (clm ts) c = lan v" using assm by simp
  have len_ge_zero:"\<parallel>len v ts c\<parallel> > 0" using assm by simp
  have len:"len v ts c = ext v" using assm by simp
  obtain v1 v2 where chop:"(v=v1\<parallel>v2) \<and> \<parallel>ext v1\<parallel> > 0 \<and> \<parallel>ext v2\<parallel> > 0 "
    using assm view.horizontal_chop_non_empty
    using length_split by blast
  from chop and len have len_v1:"len v1 ts c = ext v1"
    using len_view_hchop_left by blast
  from chop and len have len_v2:"len v2 ts c = ext v2"
    using len_view_hchop_right by blast
  from chop and restr have restr_v1:"restrict v1 (clm ts) c = lan v1"
    by (metis (no_types, lifting) hchop_def restriction.restriction_stable1)
  from chop and restr have restr_v2:"restrict v2 (clm ts) c = lan v2"
    by (metis (no_types, lifting) hchop_def restriction.restriction_stable2)
  from chop and len_v1 len_v2 restr_v1 restr_v2 show "ts,v \<Turnstile>cl(c) \<^bold>\<frown> cl(c)"
    using hchop_def assm by force
qed

lemma clm_compose: "\<Turnstile>(cl(c) \<^bold>\<frown> cl(c)  \<^bold>\<rightarrow> cl(c))"
  using  real_int.chop_dense len_compose_hchop hchop_def length_dense restrict_def
  by (metis (no_types, lifting))

lemma clm_dense:"\<Turnstile>cl(c) \<^bold>\<leftrightarrow> cl(c) \<^bold>\<frown> cl(c)"
  using clm_decompose clm_compose by blast

lemma clm_continuous :"\<Turnstile>(cl(c)) \<^bold>\<rightarrow> (\<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( \<^bold>\<not>cl(c) \<^bold>\<and> \<^bold>\<l> > 0) \<^bold>\<frown> \<^bold>\<top>))"
  by (metis (no_types, lifting) hchop_def len_view_hchop_left len_view_hchop_right
      restrict_def)

lemma res_not_free: "\<Turnstile>(\<^bold>\<exists> c. re(c) \<^bold>\<rightarrow> \<^bold>\<not>free)"
  using nat_int.card_empty_zero one_neq_zero by auto

lemma clm_not_free: "\<Turnstile>(\<^bold>\<exists> c. cl(c) \<^bold>\<rightarrow> \<^bold>\<not>free)"
  using nat_int.card_empty_zero by auto

lemma free_no_res:"\<Turnstile>(free \<^bold>\<rightarrow>  \<^bold>\<not>(\<^bold>\<exists> c. re(c)))"
  using nat_int.card_empty_zero one_neq_zero
  by (metis less_irrefl)

lemma free_no_clm:"\<Turnstile>(free \<^bold>\<rightarrow>  \<^bold>\<not>(\<^bold>\<exists> c. cl(c)))"
  using nat_int.card_empty_zero one_neq_zero by (metis less_irrefl)

lemma free_decompose:"\<Turnstile>free \<^bold>\<rightarrow> ( free \<^bold>\<frown> free)"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>free"
  obtain v1 and v2
    where non_empty_v1_v2:"(v=v1\<parallel>v2) \<and> \<parallel>ext v1\<parallel> > 0 \<and> \<parallel>ext v2\<parallel> > 0"
    using assm length_dense by blast
  have one_lane:"|lan v1| = 1 \<and> |lan v2| = 1"
    using assm hchop_def non_empty_v1_v2
    by auto
  have nothing_on_v1:
    " (\<forall>c. \<parallel>len v1 ts c\<parallel> = 0
        \<or> (restrict v1 (clm ts) c = \<emptyset> \<and> restrict v1 (res ts) c = \<emptyset>))"
    by (metis (no_types, lifting) assm len_empty_on_subview1 non_empty_v1_v2
        restriction_stable1)
  have nothing_on_v2:
    " (\<forall>c. \<parallel>len v2 ts c\<parallel> = 0
        \<or> (restrict v2 (clm ts) c = \<emptyset> \<and> restrict v2 (res ts) c = \<emptyset>))"
    by (metis (no_types, lifting) assm len_empty_on_subview2 non_empty_v1_v2
        restriction_stable2)
  have
    "(v=v1\<parallel>v2)
    \<and> 0 < \<parallel>ext v1\<parallel> \<and> |lan v1| = 1
    \<and> (\<forall>c. \<parallel>len v1 ts c\<parallel> = 0
        \<or>( restrict v1 (clm ts) c = \<emptyset> \<and> restrict v1 (res ts) c = \<emptyset>))
    \<and> 0 < \<parallel>ext v2\<parallel> \<and> |lan v2| = 1
    \<and> (\<forall>c. \<parallel>len v2 ts c\<parallel> = 0
        \<or>( restrict v2 (clm ts) c = \<emptyset> \<and> restrict v2 (res ts) c = \<emptyset>))"
    using non_empty_v1_v2 nothing_on_v1 nothing_on_v2 one_lane by blast
  then show "ts,v \<Turnstile>(free \<^bold>\<frown> free)" by blast
qed

lemma free_compose:"\<Turnstile>(free \<^bold>\<frown> free) \<^bold>\<rightarrow> free"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>free \<^bold>\<frown> free"
  have len_ge_0:"\<parallel>ext v\<parallel> > 0"
    using assm length_meld by blast
  have widt_one:"|lan v| = 1" using assm
    by (metis horizontal_chop_width_stable)
  have no_car:
    "(\<forall>c. \<parallel>len v ts c\<parallel> = 0 \<or> restrict v (clm ts) c = \<emptyset> \<and> restrict v (res ts) c = \<emptyset>)"
  proof (rule ccontr)
    assume
      "\<not>(\<forall>c. \<parallel>len v ts c\<parallel> = 0
           \<or> (restrict v (clm ts) c = \<emptyset> \<and> restrict v (res ts) c = \<emptyset>))"
    then obtain c
      where ex:
        "\<parallel>len v ts c\<parallel> \<noteq> 0 \<and> (restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>)"
      by blast
    from ex have 1:"\<parallel>len v ts c\<parallel> > 0"
      using less_eq_real_def real_int.length_ge_zero by auto
    have "(restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>)" using ex ..
    then show False
    proof
      assume "restrict v (clm ts) c \<noteq> \<emptyset>"
      then show False
        by (metis (no_types, hide_lams) assm add.left_neutral ex len_hchop_add
            restriction.restrict_def view.hchop_def)
    next
      assume "restrict v (res ts) c \<noteq> \<emptyset>"
      then show False
        by (metis (no_types, hide_lams) assm add.left_neutral ex len_hchop_add
            restriction.restrict_def view.hchop_def)
    qed
  qed
  show "ts,v \<Turnstile>free"
    using len_ge_0 widt_one no_car by blast
qed

lemma free_dense:"\<Turnstile>free \<^bold>\<leftrightarrow> (free \<^bold>\<frown> free)"
  using free_decompose free_compose by blast

lemma free_dense2:"\<Turnstile>free \<^bold>\<rightarrow> \<^bold>\<top> \<^bold>\<frown> free \<^bold>\<frown> \<^bold>\<top>"
  using horizontal_chop_empty_left horizontal_chop_empty_right  by fastforce

text \<open>
The next lemmas show the connection between the spatial. In particular,
if the view consists of one lane and a non-zero extension, where neither
a reservation nor a car resides, the view satisfies free (and vice versa).
\<close>

lemma no_cars_means_free:
  "\<Turnstile>((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>))) \<^bold>\<rightarrow> free"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:
    "ts,v \<Turnstile> ((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
  have ge_0:"ts,v \<Turnstile> \<^bold>\<l> > 0" using assm by best
  have one_lane:"ts,v \<Turnstile>\<^bold>\<omega> = 1" using assm by best
  show "ts,v \<Turnstile> free"
  proof (rule ccontr)
    have no_car: "ts,v \<Turnstile>\<^bold>\<not>( \<^bold>\<exists> c.  (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>))"
      using assm by best
    assume "ts,v \<Turnstile> \<^bold>\<not> free"
    hence contra:
      "\<not>(\<forall>c. \<parallel>len v ts c\<parallel> = 0 \<or> restrict v (clm ts) c = \<emptyset> \<and> restrict v (res ts) c = \<emptyset>)"
      using ge_0 one_lane by blast
    hence ex_car:
      "\<exists>c. \<parallel>len v ts c\<parallel> > 0 \<and> (restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>)"
      using real_int.length_ge_zero dual_order.antisym not_le
      by metis
    obtain c where c_def:
      "\<parallel>len v ts c\<parallel> > 0 \<and> (restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>)"
      using ex_car by blast
    hence "(restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq> \<emptyset>)" by best
    thus False
    proof
      assume "restrict v (clm ts) c \<noteq> \<emptyset>"
      with one_lane have clm_one:"|restrict v (clm ts) c| = 1"
        using el_in_restriction_clm_singleton
        by (metis card_non_empty_geq_one dual_order.antisym restriction.restriction_clm_leq_one)
      obtain v1 and v2 and v3 and v4
        where "v=v1\<parallel>v2" and "v2=v3\<parallel>v4"
          and len_eq:"len v3 ts c = ext v3 \<and> \<parallel>len v3 ts c\<parallel> = \<parallel>len v ts c\<parallel> "
        using horizontal_chop_empty_left horizontal_chop_empty_right
          len_fills_subview c_def by blast
      then have res_non_empty:"restrict v3 (clm ts) c \<noteq> \<emptyset>"
        using \<open>restrict v (clm ts) c \<noteq> \<emptyset>\<close> restriction_stable restriction_stable1
        by auto
      have len_non_empty:"\<parallel>len v3 ts c\<parallel> > 0"
        using len_eq c_def by auto
      have "|restrict v3 (clm ts) c| =1 "
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> clm_one restriction_stable restriction_stable1
        by auto
      have v3_one_lane:"|lan v3| = 1"
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> hchop_def one_lane
        by auto
      have clm_fills_v3:"restrict v3 (clm ts) c = lan v3"
      proof (rule ccontr)
        assume  aux:"restrict v3 (clm ts) c \<noteq> lan v3"
        have "restrict v3 (clm ts) c \<sqsubseteq> lan v3"
          by (simp add: restrict_view)
        hence "\<exists>n. n \<^bold>\<notin> restrict v3 (clm ts) c \<and> n \<^bold>\<in> lan v3"
          using aux \<open>|restrict v3 (clm ts) c| = 1\<close>
            restriction.restrict_eq_lan_subs v3_one_lane
          by auto
        hence "|lan v3| > 1"
          using \<open>| (restrict v3 (clm ts) c)| = 1\<close> \<open>restrict v3 (clm ts) c \<le> lan v3\<close> aux
            restriction.restrict_eq_lan_subs v3_one_lane
          by auto
        thus False using v3_one_lane by auto
      qed
      have "\<parallel>ext v3\<parallel> > 0" using c_def len_eq by auto
      have "ts, v3 \<Turnstile> cl(c)" using clm_one len_eq c_def clm_fills_v3 v3_one_lane
        by auto
      hence "ts,v \<Turnstile>  (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)"
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> by blast
      hence "ts,v \<Turnstile>\<^bold>\<exists> c. (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)" by blast
      thus False using no_car by best
    next
      assume "restrict v (res ts) c \<noteq> \<emptyset>"
      with one_lane have clm_one:"|restrict v (res ts) c| = 1"
        using el_in_restriction_clm_singleton
        by (metis nat_int.card_non_empty_geq_one nat_int.card_subset_le
            dual_order.antisym restrict_view)
      obtain v1 and v2 and v3 and v4
        where "v=v1\<parallel>v2" and "v2=v3\<parallel>v4"
          and len_eq:"len v3 ts c = ext v3 \<and> \<parallel>len v3 ts c\<parallel> = \<parallel>len v ts c\<parallel> "
        using horizontal_chop_empty_left horizontal_chop_empty_right
          len_fills_subview c_def by blast
      then have res_non_empty:"restrict v3 (res ts) c \<noteq> \<emptyset>"
        using \<open>restrict v (res ts) c \<noteq> \<emptyset>\<close> restriction_stable restriction_stable1
        by auto
      have len_non_empty:"\<parallel>len v3 ts c\<parallel> > 0"
        using len_eq c_def by auto
      have "|restrict v3 (res ts) c| =1 "
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> clm_one restriction_stable restriction_stable1
        by auto
      have v3_one_lane:"|lan v3| = 1"
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> hchop_def one_lane
        by auto
      have "restrict v3 (res ts) c = lan v3"
      proof (rule ccontr)
        assume  aux:"restrict v3 (res ts) c \<noteq> lan v3"
        have "restrict v3 (res ts) c \<sqsubseteq> lan v3"
          by (simp add: restrict_view)
        hence "\<exists>n. n \<^bold>\<notin> restrict v3 (res ts) c \<and> n \<^bold>\<in> lan v3"
          using aux \<open>|restrict v3 (res ts) c| = 1\<close> restriction.restrict_eq_lan_subs v3_one_lane
          by auto
        hence "|lan v3| > 1"
          using \<open>| (restrict v3 (res ts) c)| = 1\<close> \<open>restrict v3 (res ts) c \<le> lan v3\<close> aux
            restriction.restrict_eq_lan_subs v3_one_lane
          by auto
        thus False using v3_one_lane by auto
      qed
      have "\<parallel>ext v3\<parallel> > 0" using c_def len_eq by auto
      have "ts, v3 \<Turnstile> re(c)"
        using clm_one len_eq c_def \<open>restrict v3 (res ts) c = lan v3\<close> v3_one_lane
        by auto
      hence "ts,v \<Turnstile>  (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)"
        using \<open>v2=v3\<parallel>v4\<close> \<open>v=v1\<parallel>v2\<close> by blast
      hence "ts,v \<Turnstile>\<^bold>\<exists> c. (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)" by blast
      thus False using no_car by best
    qed
  qed
qed

lemma free_means_no_cars:
  "\<Turnstile>free \<^bold>\<rightarrow> ((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
proof (rule allI | rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile> free"
  have no_car:"ts,v \<Turnstile>(\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>))"
  proof (rule ccontr)
    assume "\<not> (ts,v \<Turnstile>(\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
    hence contra:"ts,v \<Turnstile> \<^bold>\<exists> c. \<^bold>\<top> \<^bold>\<frown> (cl(c) \<^bold>\<or> re(c)) \<^bold>\<frown> \<^bold>\<top>" by blast
    from this obtain c and v1 and v' and v2 and vc where
      vc_def:"(v=v1\<parallel>v') \<and> (v'=vc\<parallel>v2) \<and> (ts,vc \<Turnstile> cl(c) \<^bold>\<or> re(c))" by blast
    hence len_ge_zero:"\<parallel>len v ts c\<parallel> > 0"
      by (metis len_empty_on_subview1 len_empty_on_subview2 less_eq_real_def
          real_int.length_ge_zero)
    from vc_def have vc_ex_car:
      "restrict vc (clm ts) c \<noteq> \<emptyset> \<or> restrict vc (res ts) c \<noteq>\<emptyset>"
      using nat_int.card_empty_zero one_neq_zero by auto
    have eq_lan:"lan v = lan vc" using vc_def hchop_def by auto
    hence v_ex_car:"restrict v (clm ts) c \<noteq> \<emptyset> \<or> restrict v (res ts) c \<noteq>\<emptyset>"
      using vc_ex_car by (simp add: restrict_def)
    from len_ge_zero and v_ex_car and assm show False by force
  qed
  with assm show
    "ts,v \<Turnstile>((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
    by blast
qed

lemma free_eq_no_cars:
  "\<Turnstile>free \<^bold>\<leftrightarrow> ((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
  using no_cars_means_free free_means_no_cars by blast

lemma free_nowhere_res:"\<Turnstile>free \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<top> \<^bold>\<frown> (re(c)) \<^bold>\<frown> \<^bold>\<top>)"
  using free_eq_no_cars by blast

lemma two_res_not_res: "\<Turnstile>((re(c) \<^bold>\<smile> re(c)) \<^bold>\<rightarrow> \<^bold>\<not>re(c))"
  by (metis add_eq_self_zero one_neq_zero width_add1)

lemma two_clm_width: "\<Turnstile>((cl(c) \<^bold>\<smile> cl(c)) \<^bold>\<rightarrow> \<^bold>\<omega> = 2)"
  by (metis one_add_one width_add1)

lemma two_res_no_car: "\<Turnstile>(re(c) \<^bold>\<smile> re(c)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<exists> c. ( cl(c) \<^bold>\<or> re(c)) )"
  by (metis add_eq_self_zero one_neq_zero width_add1)

lemma two_lanes_no_car:"\<Turnstile>(\<^bold>\<not> \<^bold>\<omega>= 1) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<exists> c.(cl(c) \<^bold>\<or> re(c)))"
  by simp

lemma empty_no_car:"\<Turnstile>( \<^bold>\<l> = 0) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<exists> c.(cl(c) \<^bold>\<or> re(c)))"
  by simp

lemma car_one_lane_non_empty: "\<Turnstile>(\<^bold>\<exists> c.(cl(c) \<^bold>\<or> re(c))) \<^bold>\<rightarrow> ((\<^bold>\<omega> =1) \<^bold>\<and> (\<^bold>\<l> > 0))"
  by blast

lemma one_lane_notfree:
  "\<Turnstile>(\<^bold>\<omega> =1) \<^bold>\<and>(\<^bold>\<l>> 0) \<^bold>\<and> (\<^bold>\<not> free) \<^bold>\<rightarrow> ( (\<^bold>\<top> \<^bold>\<frown> (\<^bold>\<exists> c. (re(c) \<^bold>\<or> cl(c))) \<^bold>\<frown> \<^bold>\<top> ))"
proof (rule allI|rule impI)+
  fix ts v
  assume assm:"ts,v \<Turnstile>(\<^bold>\<omega> =1) \<^bold>\<and>(\<^bold>\<l>> 0) \<^bold>\<and> (\<^bold>\<not> free)"
  hence not_free:"ts,v \<Turnstile>\<^bold>\<not> free" by blast
  with free_eq_no_cars have
    "ts,v \<Turnstile>\<^bold>\<not> ((\<^bold>\<l>>0) \<^bold>\<and> (\<^bold>\<omega> = 1) \<^bold>\<and> (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>)))"
    by blast
  hence "ts,v \<Turnstile> \<^bold>\<not>  (\<^bold>\<forall>c. \<^bold>\<not> (\<^bold>\<top> \<^bold>\<frown>  ( cl(c) \<^bold>\<or> re(c) ) \<^bold>\<frown> \<^bold>\<top>))"
    using assm by blast
  thus "ts,v \<Turnstile>(\<^bold>\<top> \<^bold>\<frown> (\<^bold>\<exists> c. (re(c) \<^bold>\<or> cl(c))) \<^bold>\<frown> \<^bold>\<top> )" by blast
qed

lemma one_lane_empty_or_car:
  "\<Turnstile>(\<^bold>\<omega> =1) \<^bold>\<and>(\<^bold>\<l>> 0) \<^bold>\<rightarrow> (free \<^bold>\<or> (\<^bold>\<top> \<^bold>\<frown> (\<^bold>\<exists> c. (re(c) \<^bold>\<or> cl(c))) \<^bold>\<frown> \<^bold>\<top> ))"
  using one_lane_notfree by blast
end
end


(*  Title:      HOL/Library/Countable.thy
    Author:     Alexander Krauss, TU Muenchen
    Author:     Brian Huffman, Portland State University
    Author:     Jasmin Blanchette, TU Muenchen
*)

section \<open>Encoding (almost) everything into natural numbers\<close>

theory Countable
imports Old_Datatype HOL.Rat Nat_Bijection
begin

subsection \<open>The class of countable types\<close>

class countable =
  assumes ex_inj: "\<exists>to_nat :: 'a \<Rightarrow> nat. inj to_nat"

lemma countable_classI:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "OFCLASS('a, countable_class)"
proof (intro_classes, rule exI)
  show "inj f"
    by (rule injI [OF assms]) assumption
qed

subsection \<open>Conversion functions\<close>

definition to_nat :: "'a::countable \<Rightarrow> nat" where
  "to_nat = (SOME f. inj f)"

definition from_nat :: "nat \<Rightarrow> 'a::countable" where
  "from_nat = inv (to_nat :: 'a \<Rightarrow> nat)"

lemma inj_to_nat [simp]: "inj to_nat"
  by (rule exE_some [OF ex_inj]) (simp add: to_nat_def)

lemma inj_on_to_nat[simp, intro]: "inj_on to_nat S"
  using inj_to_nat by (auto simp: inj_on_def)

lemma surj_from_nat [simp]: "surj from_nat"
  unfolding from_nat_def by (simp add: inj_imp_surj_inv)

lemma to_nat_split [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
  using injD [OF inj_to_nat] by auto

lemma from_nat_to_nat [simp]:
  "from_nat (to_nat x) = x"
  by (simp add: from_nat_def)

subsection \<open>Finite types are countable\<close>

subclass (in finite) countable
proof
  have "finite (UNIV::'a set)" by (rule finite_UNIV)
  with finite_conv_nat_seg_image [of "UNIV::'a set"]
  obtain n and f :: "nat \<Rightarrow> 'a"
    where "UNIV = f ` {i. i < n}" by auto
  then have "surj f" unfolding surj_def by auto
  then have "inj (inv f)" by (rule surj_imp_inj_inv)
  then show "\<exists>to_nat :: 'a \<Rightarrow> nat. inj to_nat" by (rule exI[of inj])
qed

subsection \<open>Automatically proving countability of old-style datatypes\<close>

context
begin

qualified inductive finite_item :: "'a Old_Datatype.item \<Rightarrow> bool" where
  undefined: "finite_item undefined"
| In0: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In0 x)"
| In1: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In1 x)"
| Leaf: "finite_item (Old_Datatype.Leaf a)"
| Scons: "\<lbrakk>finite_item x; finite_item y\<rbrakk> \<Longrightarrow> finite_item (Old_Datatype.Scons x y)"

qualified function nth_item :: "nat \<Rightarrow> ('a::countable) Old_Datatype.item"
where
  "nth_item 0 = undefined"
| "nth_item (Suc n) =
  (case sum_decode n of
    Inl i \<Rightarrow>
    (case sum_decode i of
      Inl j \<Rightarrow> Old_Datatype.In0 (nth_item j)
    | Inr j \<Rightarrow> Old_Datatype.In1 (nth_item j))
  | Inr i \<Rightarrow>
    (case sum_decode i of
      Inl j \<Rightarrow> Old_Datatype.Leaf (from_nat j)
    | Inr j \<Rightarrow>
      (case prod_decode j of
        (a, b) \<Rightarrow> Old_Datatype.Scons (nth_item a) (nth_item b))))"
by pat_completeness auto

lemma le_sum_encode_Inl: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inl y)"
unfolding sum_encode_def by simp

lemma le_sum_encode_Inr: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inr y)"
unfolding sum_encode_def by simp

qualified termination
by (relation "measure id")
  (auto simp flip: sum_encode_eq prod_encode_eq
    simp: le_imp_less_Suc le_sum_encode_Inl le_sum_encode_Inr
    le_prod_encode_1 le_prod_encode_2)

lemma nth_item_covers: "finite_item x \<Longrightarrow> \<exists>n. nth_item n = x"
proof (induct set: finite_item)
  case undefined
  have "nth_item 0 = undefined" by simp
  thus ?case ..
next
  case (In0 x)
  then obtain n where "nth_item n = x" by fast
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inl n))))) = Old_Datatype.In0 x" by simp
  thus ?case ..
next
  case (In1 x)
  then obtain n where "nth_item n = x" by fast
  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inr n))))) = Old_Datatype.In1 x" by simp
  thus ?case ..
next
  case (Leaf a)
  have "nth_item (Suc (sum_encode (Inr (sum_encode (Inl (to_nat a)))))) = Old_Datatype.Leaf a"
    by simp
  thus ?case ..
next
  case (Scons x y)
  then obtain i j where "nth_item i = x" and "nth_item j = y" by fast
  hence "nth_item
    (Suc (sum_encode (Inr (sum_encode (Inr (prod_encode (i, j))))))) = Old_Datatype.Scons x y"
    by simp
  thus ?case ..
qed

theorem countable_datatype:
  fixes Rep :: "'b \<Rightarrow> ('a::countable) Old_Datatype.item"
  fixes Abs :: "('a::countable) Old_Datatype.item \<Rightarrow> 'b"
  fixes rep_set :: "('a::countable) Old_Datatype.item \<Rightarrow> bool"
  assumes type: "type_definition Rep Abs (Collect rep_set)"
  assumes finite_item: "\<And>x. rep_set x \<Longrightarrow> finite_item x"
  shows "OFCLASS('b, countable_class)"
proof
  define f where "f y = (LEAST n. nth_item n = Rep y)" for y
  {
    fix y :: 'b
    have "rep_set (Rep y)"
      using type_definition.Rep [OF type] by simp
    hence "finite_item (Rep y)"
      by (rule finite_item)
    hence "\<exists>n. nth_item n = Rep y"
      by (rule nth_item_covers)
    hence "nth_item (f y) = Rep y"
      unfolding f_def by (rule LeastI_ex)
    hence "Abs (nth_item (f y)) = y"
      using type_definition.Rep_inverse [OF type] by simp
  }
  hence "inj f"
    by (rule inj_on_inverseI)
  thus "\<exists>f::'b \<Rightarrow> nat. inj f"
    by - (rule exI)
qed

ML \<open>
  fun old_countable_datatype_tac ctxt =
    SUBGOAL (fn (goal, _) =>
      let
        val ty_name =
          (case goal of
            (_ $ Const (\<^const_name>\<open>Pure.type\<close>, Type (\<^type_name>\<open>itself\<close>, [Type (n, _)]))) => n
          | _ => raise Match)
        val typedef_info = hd (Typedef.get_info ctxt ty_name)
        val typedef_thm = #type_definition (snd typedef_info)
        val pred_name =
          (case HOLogic.dest_Trueprop (Thm.concl_of typedef_thm) of
            (_ $ _ $ _ $ (_ $ Const (n, _))) => n
          | _ => raise Match)
        val induct_info = Inductive.the_inductive_global ctxt pred_name
        val pred_names = #names (fst induct_info)
        val induct_thms = #inducts (snd induct_info)
        val alist = pred_names ~~ induct_thms
        val induct_thm = the (AList.lookup (op =) alist pred_name)
        val vars = rev (Term.add_vars (Thm.prop_of induct_thm) [])
        val insts = vars |> map (fn (_, T) => try (Thm.cterm_of ctxt)
          (Const (\<^const_name>\<open>Countable.finite_item\<close>, T)))
        val induct_thm' = Thm.instantiate' [] insts induct_thm
        val rules = @{thms finite_item.intros}
      in
        SOLVED' (fn i => EVERY
          [resolve_tac ctxt @{thms countable_datatype} i,
           resolve_tac ctxt [typedef_thm] i,
           eresolve_tac ctxt [induct_thm'] i,
           REPEAT (resolve_tac ctxt rules i ORELSE assume_tac ctxt i)]) 1
      end)
\<close>

end

subsection \<open>Automatically proving countability of datatypes\<close>

ML_file \<open>../Tools/BNF/bnf_lfp_countable.ML\<close>

ML \<open>
fun countable_datatype_tac ctxt st =
  (case \<^try>\<open>HEADGOAL (old_countable_datatype_tac ctxt) st\<close> of
    SOME res => res
  | NONE => BNF_LFP_Countable.countable_datatype_tac ctxt st);

(* compatibility *)
fun countable_tac ctxt =
  SELECT_GOAL (countable_datatype_tac ctxt);
\<close>

method_setup countable_datatype = \<open>
  Scan.succeed (SIMPLE_METHOD o countable_datatype_tac)
\<close> "prove countable class instances for datatypes"

subsection \<open>More Countable types\<close>

text \<open>Naturals\<close>

instance nat :: countable
  by (rule countable_classI [of "id"]) simp

text \<open>Pairs\<close>

instance prod :: (countable, countable) countable
  by (rule countable_classI [of "\<lambda>(x, y). prod_encode (to_nat x, to_nat y)"])
    (auto simp add: prod_encode_eq)

text \<open>Sums\<close>

instance sum :: (countable, countable) countable
  by (rule countable_classI [of "(\<lambda>x. case x of Inl a \<Rightarrow> to_nat (False, to_nat a)
                                     | Inr b \<Rightarrow> to_nat (True, to_nat b))"])
    (simp split: sum.split_asm)

text \<open>Integers\<close>

instance int :: countable
  by (rule countable_classI [of int_encode]) (simp add: int_encode_eq)

text \<open>Options\<close>

instance option :: (countable) countable
  by countable_datatype

text \<open>Lists\<close>

instance list :: (countable) countable
  by countable_datatype

text \<open>String literals\<close>

instance String.literal :: countable
  by (rule countable_classI [of "to_nat \<circ> String.explode"]) (simp add: String.explode_inject)

text \<open>Functions\<close>

instance "fun" :: (finite, countable) countable
proof
  obtain xs :: "'a list" where xs: "set xs = UNIV"
    using finite_list [OF finite_UNIV] ..
  show "\<exists>to_nat::('a \<Rightarrow> 'b) \<Rightarrow> nat. inj to_nat"
  proof
    show "inj (\<lambda>f. to_nat (map f xs))"
      by (rule injI, simp add: xs fun_eq_iff)
  qed
qed

text \<open>Typereps\<close>

instance typerep :: countable
  by countable_datatype

subsection \<open>The rationals are countably infinite\<close>

definition nat_to_rat_surj :: "nat \<Rightarrow> rat" where
  "nat_to_rat_surj n = (let (a, b) = prod_decode n in Fract (int_decode a) (int_decode b))"

lemma surj_nat_to_rat_surj: "surj nat_to_rat_surj"
unfolding surj_def
proof
  fix r::rat
  show "\<exists>n. r = nat_to_rat_surj n"
  proof (cases r)
    fix i j assume [simp]: "r = Fract i j" and "j > 0"
    have "r = (let m = int_encode i; n = int_encode j in nat_to_rat_surj (prod_encode (m, n)))"
      by (simp add: Let_def nat_to_rat_surj_def)
    thus "\<exists>n. r = nat_to_rat_surj n" by(auto simp: Let_def)
  qed
qed

lemma Rats_eq_range_nat_to_rat_surj: "\<rat> = range nat_to_rat_surj"
  by (simp add: Rats_def surj_nat_to_rat_surj)

context field_char_0
begin

lemma Rats_eq_range_of_rat_o_nat_to_rat_surj:
  "\<rat> = range (of_rat \<circ> nat_to_rat_surj)"
  using surj_nat_to_rat_surj
  by (auto simp: Rats_def image_def surj_def) (blast intro: arg_cong[where f = of_rat])

lemma surj_of_rat_nat_to_rat_surj:
  "r \<in> \<rat> \<Longrightarrow> \<exists>n. r = of_rat (nat_to_rat_surj n)"
  by (simp add: Rats_eq_range_of_rat_o_nat_to_rat_surj image_def)

end

instance rat :: countable
proof
  show "\<exists>to_nat::rat \<Rightarrow> nat. inj to_nat"
  proof
    have "surj nat_to_rat_surj"
      by (rule surj_nat_to_rat_surj)
    then show "inj (inv nat_to_rat_surj)"
      by (rule surj_imp_inj_inv)
  qed
qed

theorem rat_denum: "\<exists>f :: nat \<Rightarrow> rat. surj f"
 using surj_nat_to_rat_surj by metis

end


(*  Title:      HOL/Quickcheck_Examples/Completeness.thy
    Author:     Lukas Bulwahn
    Copyright   2012 TU Muenchen
*)

section {* Proving completeness of exhaustive generators *}

theory Completeness
imports Main
begin

subsection {* Preliminaries *}

primrec is_some
where
  "is_some (Some t) = True"
| "is_some None = False"

lemma is_some_is_not_None:
  "is_some x \<longleftrightarrow> x \<noteq> None"
  by (cases x) simp_all

setup Exhaustive_Generators.setup_exhaustive_datatype_interpretation

subsection {* Defining the size of values *}

hide_const size

class size =
  fixes size :: "'a => nat"

instantiation int :: size
begin

definition size_int :: "int => nat"
where
  "size_int n = nat (abs n)"

instance ..

end

instantiation natural :: size
begin

definition size_natural :: "natural => nat"
where
  "size_natural = nat_of_natural"

instance ..

end

instantiation nat :: size
begin

definition size_nat :: "nat => nat"
where
  "size_nat n = n"

instance ..

end

instantiation list :: (size) size
begin

primrec size_list :: "'a list => nat"
where
  "size [] = 1"
| "size (x # xs) = max (size x) (size xs) + 1"

instance ..

end

subsection {* Completeness *}

class complete = exhaustive + size +
assumes
   complete: "(\<exists> v. size v \<le> n \<and> is_some (f v)) \<longleftrightarrow> is_some (exhaustive_class.exhaustive f (natural_of_nat n))"

lemma complete_imp1:
  "size (v :: 'a :: complete) \<le> n \<Longrightarrow> is_some (f v) \<Longrightarrow> is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
by (metis complete)

lemma complete_imp2:
  assumes "is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
  obtains v where "size (v :: 'a :: complete) \<le> n" "is_some (f v)"
using assms by (metis complete)

subsubsection {* Instance Proofs *}

declare exhaustive_int'.simps [simp del]

lemma complete_exhaustive':
  "(\<exists> i. j <= i & i <= k & is_some (f i)) \<longleftrightarrow> is_some (Quickcheck_Exhaustive.exhaustive_int' f k j)"
proof (induct rule: Quickcheck_Exhaustive.exhaustive_int'.induct[of _ f k j])
  case (1 f d i)
  show ?case
  proof (cases "f i")
    case None
    from this 1 show ?thesis
    unfolding exhaustive_int'.simps[of _ _ i] Quickcheck_Exhaustive.orelse_def
    apply (auto simp add: add1_zle_eq dest: less_imp_le)
    apply auto
    done
  next
    case Some
    from this show ?thesis
    unfolding exhaustive_int'.simps[of _ _ i] Quickcheck_Exhaustive.orelse_def by auto
  qed
qed

instance int :: complete
proof
  fix n f
  show "(\<exists>v. size (v :: int) \<le> n \<and> is_some (f v)) = is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
    unfolding exhaustive_int_def complete_exhaustive'[symmetric]
    apply auto apply (rule_tac x="v" in exI)
    unfolding size_int_def by (metis abs_le_iff minus_le_iff nat_le_iff)+
qed

declare exhaustive_natural'.simps[simp del]

lemma complete_natural':
  "(\<exists>n. j \<le> n \<and> n \<le> k \<and> is_some (f n)) =
    is_some (Quickcheck_Exhaustive.exhaustive_natural' f k j)"
proof (induct rule: exhaustive_natural'.induct[of _ f k j])
  case (1 f k j)
  show "(\<exists>n\<ge>j. n \<le> k \<and> is_some (f n)) = is_some (Quickcheck_Exhaustive.exhaustive_natural' f k j)"
  unfolding exhaustive_natural'.simps [of f k j] Quickcheck_Exhaustive.orelse_def
  apply (auto split: option.split)
  apply (auto simp add: less_eq_natural_def less_natural_def 1 [symmetric] dest: Suc_leD)
  apply (metis is_some.simps(2) natural_eqI not_less_eq_eq order_antisym)
  done
qed

instance natural :: complete
proof
  fix n f
  show "(\<exists>v. size (v :: natural) \<le> n \<and> is_some (f v)) \<longleftrightarrow> is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
  unfolding exhaustive_natural_def complete_natural' [symmetric]
    by (auto simp add: size_natural_def less_eq_natural_def)
qed

instance nat :: complete
proof
  fix n f
  show "(\<exists>v. size (v :: nat) \<le> n \<and> is_some (f v)) \<longleftrightarrow> is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
    unfolding exhaustive_nat_def complete[of n "%x. f (nat_of_natural x)", symmetric]
    apply auto
    apply (rule_tac x="natural_of_nat v" in exI)
    apply (auto simp add: size_natural_def size_nat_def) done
qed

instance list :: (complete) complete
proof
  fix n f
  show "(\<exists> v. size (v :: 'a list) \<le> n \<and> is_some (f (v :: 'a list))) \<longleftrightarrow> is_some (exhaustive_class.exhaustive f (natural_of_nat n))"
  proof (induct n arbitrary: f)
    case 0
    { fix v have "size (v :: 'a list) > 0" by (induct v) auto }
    from this show ?case by (simp add: list.exhaustive_list.simps)
  next
    case (Suc n)
    show ?case
    proof
      assume "\<exists>v. Completeness.size_class.size v \<le> Suc n \<and> is_some (f v)"
      then obtain v where v: "size v \<le> Suc n" "is_some (f v)" by blast
      show "is_some (exhaustive_class.exhaustive f (natural_of_nat (Suc n)))"
      proof (cases "v")
      case Nil
        from this v show ?thesis
          unfolding list.exhaustive_list.simps[of _ "natural_of_nat (Suc n)"] Quickcheck_Exhaustive.orelse_def
          by (auto split: option.split simp add: less_natural_def)
      next
      case (Cons v' vs')
        from Cons v have size_v': "Completeness.size_class.size v' \<le> n"
          and "Completeness.size_class.size vs' \<le> n" by auto
        from Suc v Cons this have "is_some (exhaustive_class.exhaustive (\<lambda>xs. f (v' # xs)) (natural_of_nat n))"
          by metis
        from complete_imp1[OF size_v', of "%x. (exhaustive_class.exhaustive (\<lambda>xs. f (x # xs)) (natural_of_nat n))", OF this]
        show ?thesis
          unfolding list.exhaustive_list.simps[of _ "natural_of_nat (Suc n)"] Quickcheck_Exhaustive.orelse_def
          by (auto split: option.split simp add: less_natural_def)
      qed
    next
      assume is_some: "is_some (exhaustive_class.exhaustive f (natural_of_nat (Suc n)))"
      show "\<exists>v. size v \<le> Suc n \<and> is_some (f v)"
      proof (cases "f []")
        case Some
        then show ?thesis
        by (metis Suc_eq_plus1 is_some.simps(1) le_add2 size_list.simps(1))
      next
        case None
        with is_some have
          "is_some (exhaustive_class.exhaustive (\<lambda>x. exhaustive_class.exhaustive (\<lambda>xs. f (x # xs)) (natural_of_nat n)) (natural_of_nat n))"
          unfolding list.exhaustive_list.simps[of _ "natural_of_nat (Suc n)"] Quickcheck_Exhaustive.orelse_def
          by (simp add: less_natural_def)
        then obtain v' where
            v: "size v' \<le> n"
              "is_some (exhaustive_class.exhaustive (\<lambda>xs. f (v' # xs)) (natural_of_nat n))"
          by (rule complete_imp2)
        with Suc[of "%xs. f (v' # xs)"]
        obtain vs' where vs': "size vs' \<le> n" "is_some (f (v' # vs'))"
          by metis
        with v have "size (v' # vs') \<le> Suc n" by auto
        with vs' v show ?thesis by metis
      qed
    qed
  qed
qed

end