theory UPair (*Possibly rename to 'FiniteSets'*)
  imports EmptySet
begin

context GZF begin

subsection \<open>Unordered pairs; defined by replacement over \<P> (\<P> \<emptyset>)\<close>

abbreviation "\<phi> x y a b \<equiv> (a = \<emptyset> \<and> b = x) \<or> (a = \<P> \<emptyset> \<and> b = y)"

definition upair' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "upair' x y \<equiv> Repl (\<P> (\<P> \<emptyset>)) (\<phi> x y)"

definition upair :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> where
  "upair x y \<equiv> if \<not> x : SetMem then
                  if \<not> GZF_default : Set
                  then GZF_default else x
               else
                if \<not> y : SetMem then
                  if \<not> GZF_default : Set
                  then GZF_default else y
                else upair' x y"

lemma upair_eq :
  assumes "x : SetMem" "y : SetMem"
    shows "upair x y = upair' x y"
  unfolding upair_def using assms by auto

definition sng :: "'a \<Rightarrow> 'a" where
  "sng x \<equiv> upair x x"

end

syntax
  "_upair" :: "['d, 'd] \<Rightarrow> 'd" (\<open>{_,_}\<close>)
  "_sng"   :: "'d \<Rightarrow> 'd"       (\<open>{_}\<close>)
translations
  "{X,Y}" \<rightleftharpoons> "CONST upair X Y"
  "{X}"   \<rightleftharpoons> "CONST sng X"

context GZF begin

lemma pow_not_emp :
  assumes "x : Set"
    shows "\<P> x \<noteq> \<emptyset>"
  by (rule not_emptyI, rule pow_bottom[OF assms])

lemma pemp_set  : "\<P> \<emptyset> : Set"   by (rule pow_set[OF emp_set])
lemma ppemp_set : "\<P> \<P> \<emptyset> : Set" by (rule pow_set[OF pemp_set])

lemma phi_replpred :
  assumes "x : SetMem" "y : SetMem" "z : Set"
    shows "\<phi> x y : ReplPred z"
proof (insert assms, unfold ReplPred_def has_ty_def, auto)
  fix a show "\<exists>\<^sub>\<le>\<^sub>1 b : SetMem. \<phi> x y a b" unfolding ReplPred_def
    by (unfold tuniq_def, rule, use pow_not_emp[OF emp_set] in auto)
qed

lemma upair_typ : "upair : SetMem \<rightarrow> SetMem \<rightarrow> Set"
proof (rule funI[THEN funI])
  fix a b :: 'a assume ab: "a : SetMem" "b : SetMem"
  have "\<P> (\<P> \<emptyset>) : Set" by (rule pow_set[OF pow_set[OF emp_set]])
  thus "{a, b} : Set" unfolding upair_eq[OF ab] upair'_def
    using repl_set[OF _ phi_replpred[OF ab]] by auto
qed

lemmas upair_set = funE[OF funE[OF upair_typ]]

lemma pow_emp_iff :  "x \<in> \<P> \<emptyset> \<longleftrightarrow> x = \<emptyset>"
proof
  assume "x \<in> \<P> \<emptyset>"
  hence "x : Set" "x \<subseteq> \<emptyset>"
    using pow_mem[OF emp_set] pow_iff[OF _ emp_set] by auto
  hence "\<forall>a. a \<notin> x" using subset_iff by auto
  thus "x = \<emptyset>" using equals0I[OF \<open>x : Set\<close>] by blast
next
  assume "x = \<emptyset>" thus "x \<in> \<P> \<emptyset>"
    using pow_bottom[OF emp_set] by auto
qed

lemma pow_pow_emp_iff : "x \<in> \<P> (\<P> \<emptyset>) \<longleftrightarrow> (x = \<emptyset> \<or> x = \<P> \<emptyset>)"
proof
  assume "x \<in> \<P> \<P> \<emptyset>" hence "x : Set" "x \<subseteq> \<P> \<emptyset>" using pow_mem powD pemp_set by auto
  have "x = \<emptyset> \<or> (\<exists>y. y \<in> x)" by (rule set_disj[OF \<open>x : Set\<close>])
  thus "x = \<emptyset> \<or> x = \<P> \<emptyset>"
  proof (rule, simp)
    assume "\<exists>y. y \<in> x" hence "\<emptyset> \<in> x"
      using subsetD[OF \<open>x \<subseteq> \<P> \<emptyset>\<close>] pow_emp_iff by auto
    have "x = \<P> \<emptyset>" proof (rule equality_iffI[OF \<open>x : Set\<close> pemp_set], rule)
      fix a
      show "a \<in> x \<Longrightarrow> a \<in> \<P> \<emptyset>" using subsetD[OF \<open>x \<subseteq> \<P> \<emptyset>\<close>] by auto
      show "a \<in> \<P> \<emptyset> \<Longrightarrow> a \<in> x" using \<open>\<emptyset> \<in> x\<close> pow_emp_iff by auto
    qed
    thus "x = \<emptyset> \<or> x = \<P> \<emptyset>" by simp
  qed
next
  assume "x = \<emptyset> \<or> x = \<P> \<emptyset>" hence "x : Set" "x \<subseteq> \<P> \<emptyset>"
    using empty_subsetI subset_refl emp_set pow_set by auto
  thus "x \<in> \<P> \<P> \<emptyset>" using powI[OF _ pemp_set] by auto
qed

lemma \<phi>_uniq : "\<phi> x y a b \<Longrightarrow> (\<forall>z. \<phi> x y a z \<longrightarrow> z = b)"
  using pow_emp_iff by blast

lemma upair_iff :
  assumes "x : SetMem" "y : SetMem"
  shows "b \<in> upair x y \<longleftrightarrow> (b = x \<or> b = y)"
proof -
  have pp_emp_set : "\<P> \<P> \<emptyset> : Set" by (rule pow_set[OF pow_set[OF emp_set]])
  show ?thesis unfolding upair_eq[OF assms] upair'_def
  proof (rule, erule replaceE[OF pp_emp_set phi_replpred[OF assms pp_emp_set]])
    fix a assume "a \<in> (\<P> \<P> \<emptyset>)" and "\<phi> x y a b"
    thus "(b = x \<or> b = y)" using pow_pow_emp_iff by auto
  next
    assume "(b = x \<or> b = y)"
    thus "b \<in> Repl  (\<P> \<P> \<emptyset>) (\<phi> x y)"
    proof
      assume "b = x"
      show "b \<in> Repl (\<P> \<P> \<emptyset>) (\<phi> x y)"
      proof (rule replaceI[OF pp_emp_set phi_replpred[OF assms pp_emp_set]])
        let ?a = "\<emptyset>"
        show "\<phi> x y ?a b" "b : SetMem"
          using \<open>x : SetMem\<close> \<open>b = x\<close> by simp_all
        show "\<emptyset> \<in> \<P> (\<P> \<emptyset>)"
          using pow_pow_emp_iff by simp
      qed
    next
      assume "b = y"
      show "b \<in> Repl (\<P> \<P> \<emptyset>) (\<phi> x y)"
      proof (rule replaceI[OF pp_emp_set phi_replpred[OF assms pp_emp_set]])
        let ?a = "\<P> \<emptyset>"
        show "\<phi> x y ?a b" "b : SetMem"
          using \<open>y : SetMem\<close> \<open>b = y\<close> by simp_all
        show "\<P> \<emptyset> \<in> \<P> (\<P> \<emptyset>)"
          using pow_pow_emp_iff by simp
      qed
    qed
  qed
qed

lemma upairI1 :
  assumes "a : SetMem" "b : SetMem"
  shows "a \<in> {a, b}" using upair_iff[OF assms] by simp

lemma upairI2 :
  assumes "a : SetMem" "b : SetMem"
  shows "b \<in> {a, b}" using upair_iff[OF assms] by simp

lemma upairE :
  assumes "b : SetMem" "c : SetMem"
  shows "\<lbrakk> a \<in> {b, c} ; a=b \<Longrightarrow> P ; a=c \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (simp add: upair_iff[OF assms], blast)

lemma upair'_set :
  assumes "b : SetMem" "c : SetMem"
  shows "upair' b c : Set"
  using upair_set[OF assms]
  unfolding upair_eq[OF assms] .

lemma not_setmem_not_set :
  "\<not> x : SetMem \<Longrightarrow> \<not> x : Set"
  using set_setmem by auto

lemma upair_set_setmem :
  assumes "{b,c} : Set"
    shows "b : SetMem \<and> c : SetMem"
proof (rule ccontr, auto)
  assume b:"\<not> b : SetMem"
  hence "\<not> {b, c} : Set"
    using not_setmem_not_set[OF b]
    unfolding upair_def by auto
  thus "False" using assms ..
next
  assume c:"\<not> c : SetMem"
  hence "\<not> {b, c} : Set"
    using not_setmem_not_set
    unfolding upair_def by auto
  thus "False" using assms ..
qed

lemmas upair_smem1 = conjunct1[OF upair_set_setmem]
   and upair_smem2 = conjunct2[OF upair_set_setmem]

subsection \<open>Rules for singleton sets\<close>

lemma sng_typ : "sng : SetMem \<rightarrow> Set"
  by (rule funI, unfold sng_def, rule upair_set, auto)
lemmas sng_set = funE[OF sng_typ]

lemma sng_iff :
  assumes "x : SetMem"
    shows "a \<in> {x} \<longleftrightarrow> a = x"
  unfolding sng_def using upair_iff[OF assms assms]
  by auto

lemma sngI :
  assumes "a : SetMem"
    shows "a \<in> {a}"
  using sng_iff[OF \<open>a : SetMem\<close>]
  by auto

lemma sngE :
  assumes "x : SetMem"
    shows "\<lbrakk> a \<in> {x} ; a = x \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using sng_iff[OF \<open>x : SetMem\<close>]
  by auto

lemma sng_setof :
  assumes a : "a : SetMem" "a : P"
  shows "{a} : SetOf P"
  using setofI[OF sng_set[OF a(1)]] a
  unfolding sng_iff[OF a(1)] by auto

subsection \<open>Properties of upairs and singletons\<close>

lemma upair_subset:
  assumes "a : SetMem" "b : SetMem" "x : Set"
    shows "a \<in> x \<Longrightarrow> b \<in> x \<Longrightarrow> {a, b} \<subseteq> x"
  using upair_iff[OF assms(1,2)]
  by auto

lemma sng_subset:
  assumes "a : SetMem" "x : Set"
    shows "a \<in> x \<Longrightarrow> {a} \<subseteq> x"
  unfolding sng_def
  using upair_subset[OF \<open>a : SetMem\<close> \<open>a : SetMem\<close> \<open>x : Set\<close>]
  by auto

lemma sng_eq_iff :
  assumes "a : SetMem" "b : SetMem"
    shows "{a} = {b} \<longleftrightarrow> a=b"
  by (rule equality_iff[OF sng_set[OF \<open>a : SetMem\<close>], OF sng_set[OF \<open>b : SetMem\<close>], THEN cnf.iff_trans],
      use sng_iff assms in auto)

lemma upair_eq_iff :
  assumes "a : SetMem" "b : SetMem" "c : SetMem" "d : SetMem"
    shows "{a, b} = {c,d} \<longleftrightarrow> ((a=c \<and> b=d) \<or> (a=d \<and> b=c))"
proof (rule equality_iff[OF upair_set[OF assms(1,2)] upair_set[OF assms(3,4)], THEN cnf.iff_trans], rule)
  assume eq:"\<forall>x. x \<in> {a, b} \<longleftrightarrow> x \<in> {c,d}"
  have "a = b \<or> a \<noteq> b" by simp
  thus "a = c \<and> b = d \<or> a = d \<and> b = c"
  proof
    assume "a = b" hence "{a, b} = {a}" unfolding sng_def by simp
    hence "c = a \<and> d = a" using eq upair_iff assms sng_iff by auto
    thus "a = c \<and> b = d \<or> a = d \<and> b = c" using \<open>a = b\<close> by auto
  next
    assume "a \<noteq> b"
    have "a \<in> upair c d" "b \<in> upair c d" using eq upairI1 upairI2 assms by auto
    thus "a = c \<and> b = d \<or> a = d \<and> b = c" using \<open>a\<noteq>b\<close> upair_iff assms by auto
  qed
next
  assume "a = c \<and> b = d \<or> a = d \<and> b = c"
  thus "\<forall>x. (x \<in> {a, b}) \<longleftrightarrow> (x \<in> upair c d)" using upair_iff assms by auto
qed

end
end


theory List_Demo
imports Main
begin

datatype 'a list = Nil | Cons "'a" "'a list"

term "Nil"

(* In this special situation: *)
declare [[names_short]]

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = xs"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

theorem rev_rev: "rev (rev xs) = xs"
apply (induction xs)
apply (auto)
done

end


theory TheoremD9
imports TheoremD8
begin

context LocalLexing begin

definition items_le :: "nat \<Rightarrow> items \<Rightarrow> items"
where
  "items_le k I = { x . x \<in> I \<and> item_end x \<le> k }"

definition items_eq :: "nat \<Rightarrow> items \<Rightarrow> items"
where
  "items_eq k I = { x . x \<in> I \<and> item_end x = k }"

definition paths_le :: "nat \<Rightarrow> tokens set \<Rightarrow> tokens set"
where
  "paths_le k P = { p . p \<in> P \<and> charslength p \<le> k }"

definition paths_eq :: "nat \<Rightarrow> tokens set \<Rightarrow> tokens set"
where
  "paths_eq k P = { p . p \<in> P \<and> charslength p = k }"

lemma items_le_pointwise: "pointwise (items_le k)"
  by (auto simp add: pointwise_def items_le_def)

lemma items_le_is_filter: "items_le k I \<subseteq> I"
  by (auto simp add: items_le_def)

lemma items_eq_pointwise: "pointwise (items_eq k)"
  by (auto simp add: pointwise_def items_eq_def)

lemma items_eq_is_filter: "items_eq k I \<subseteq> I"
  by (auto simp add: items_eq_def)

lemma paths_le_pointwise: "pointwise (paths_le k)"
  by (auto simp add: pointwise_def paths_le_def)

lemma paths_le_continuous: "continuous (paths_le k)"
  by (simp add: paths_le_pointwise pointbased_implies_continuous pointwise_implies_pointbased)

lemma paths_le_mono: "mono (paths_le k)"
  by (simp add: continuous_imp_mono paths_le_continuous)

lemma paths_le_is_filter: "paths_le k P \<subseteq> P"
  by (auto simp add: paths_le_def)

lemma paths_eq_pointwise: "pointwise (paths_eq k)"
  by (auto simp add: pointwise_def paths_eq_def)

lemma paths_eq_is_filter: "paths_eq k P \<subseteq> P"
  by (auto simp add: paths_eq_def)

lemma Predict_item_end: "x \<in> Predict k Y \<Longrightarrow> item_end x = k \<or> x \<in> Y"
  using Predict_def by auto

lemma Complete_item_end: "x \<in> Complete k Y \<Longrightarrow> item_end x = k \<or> x \<in> Y"
  using Complete_def by auto

lemma \<J>_0_0_item_end: "x \<in> \<J> 0 0 \<Longrightarrow> item_end x = 0"
  apply (simp add: \<pi>_def)
  proof (induct rule: limit_induct)
    case (Init x) thus ?case by (auto simp add: Init_def)
  next
    case (Iterate x Y)
    then have "x \<in> Complete 0 (Predict 0 Y)" by (simp add: Scan_empty)
    then have "item_end x = 0 \<or> x \<in> Predict 0 Y" using Complete_item_end by blast
    then have "item_end x = 0 \<or> x \<in> Y" using Predict_item_end by blast
    then show ?case using Iterate by blast
  qed

lemma items_le_\<J>_0_0: "items_le 0 (\<J> 0 0) = \<J> 0 0"
  using LocalLexing.\<J>_0_0_item_end LocalLexing.items_le_def LocalLexing_axioms by blast

lemma paths_le_\<P>_0_0: "paths_le 0 (\<P> 0 0) = \<P> 0 0"
  by (auto simp add: paths_le_def)

definition empty_tokens :: "token set \<Rightarrow> token set"
where
  "empty_tokens T = { t . t \<in> T \<and> chars_of_token t = [] }"

lemma items_le_Predict: "items_le k (Predict k I) = Predict k (items_le k I)"
  by (auto simp add: items_le_def Predict_def bin_def)

lemma items_le_Complete:
  "wellformed_items I \<Longrightarrow> items_le k (Complete k I) = Complete k (items_le k I)"
  by (auto simp add: items_le_def Complete_def bin_def is_complete_def wellformed_items_def
    wellformed_item_def)

lemma items_le_Scan:
  "items_le k (Scan T k I) = Scan (empty_tokens T) k (items_le k I)"
  by (auto simp add: items_le_def Scan_def bin_def empty_tokens_def)

lemma wellformed_items_Gen: "wellformed_items (Gen P)"
  using Gen_implies_pvalid pvalid_def wellformed_items_def by blast

lemma wellformed_\<J>_0_0: "wellformed_items (\<J> 0 0)"
  using thmD8 wellformed_items_Gen by auto

lemma wellformed_items_Predict:
  "wellformed_items I \<Longrightarrow> wellformed_items (Predict k I)"
  by (auto simp add: wellformed_items_def wellformed_item_def Predict_def bin_def)

lemma wellformed_items_Complete:
  "wellformed_items I \<Longrightarrow> wellformed_items (Complete k I)"
  apply (auto simp add: wellformed_items_def wellformed_item_def Complete_def bin_def)
  apply (metis dual_order.trans)
  using is_complete_def next_symbol_not_complete not_less_eq_eq by blast

lemma \<X>_length_bound: "(t, c) \<in> \<X> k \<Longrightarrow> k + length c \<le> length Doc"
  using \<X>_is_prefix is_prefix_length not_le by fastforce

lemma wellformed_items_Scan:
  "wellformed_items I \<Longrightarrow> T \<subseteq> \<X> k \<Longrightarrow> wellformed_items (Scan T k I)"
  apply (auto simp add: wellformed_items_def wellformed_item_def Scan_def bin_def \<X>_length_bound)
  using is_complete_def next_symbol_not_complete not_less_eq_eq by blast

lemma wellformed_items_\<pi>:
  assumes "wellformed_items I"
  assumes "T \<subseteq> \<X> k"
  shows "wellformed_items (\<pi> k T I)"
proof -
  {
    fix x :: item
    have "x \<in> \<pi> k T I \<Longrightarrow> wellformed_item x"
    proof (simp add: \<pi>_def, induct rule: limit_induct)
      case (Init x) thus ?case using assms(1) by (simp add: wellformed_items_def)
    next
      case (Iterate x Y)
      have "wellformed_items Y" by (simp add: Iterate.hyps(1) wellformed_items_def)
      then have "wellformed_items (Scan T k (Complete k (Predict k Y)))"
        by (simp add: assms(2) wellformed_items_Complete wellformed_items_Predict
          wellformed_items_Scan)
      then show ?case by (simp add: Iterate.hyps(2) wellformed_items_def)
    qed
  }
  then show ?thesis using wellformed_items_def by auto
qed

lemma \<J>_subset_Suc_u: "\<J> k u \<subseteq> \<J> k (Suc u)"
  by (metis Complete_\<pi>_fix Complete_subset_\<pi> \<J>.simps(1) \<J>.simps(2) \<J>.simps(3) not0_implies_Suc)

lemma mono_TokensAt: "mono (TokensAt k)"
  by (auto simp add: mono_def TokensAt_def bin_def)

lemma \<T>_subset_TokensAt: "\<T> k u \<subseteq> TokensAt k (\<J> k u)"
proof (induct u)
  case 0 thus ?case by simp
next
  case (Suc u)
    have 1: "Tokens k (\<T> k u) (\<J> k u) = Sel (\<T> k u) (TokensAt k (\<J> k u))"
      by (simp add: Tokens_def)
    have 2: "Sel (\<T> k u) (TokensAt k (\<J> k u)) \<subseteq> TokensAt k (\<J> k u)"
      by (simp add: Sel_upper_bound Suc.hyps)
    have "\<T> k (Suc u) \<subseteq> TokensAt k (\<J> k u)"
      by (simp add: 1 2)
    then show ?case
      by (meson \<J>_subset_Suc_u mono_TokensAt mono_subset_elem subset_iff)
qed

lemma TokensAt_subset_\<X>: "TokensAt k I \<subseteq> \<X> k"
  using TokensAt_def \<X>_def is_terminal_def by auto

lemma wellformed_items_\<J>_induct_u:
  assumes "wellformed_items (\<J> k u)"
  shows "wellformed_items (\<J> k (Suc u))"
proof -
  {
    fix x :: item
    have "x \<in> \<J> k (Suc u) \<Longrightarrow> wellformed_item x"
    proof (simp add: \<pi>_def, induct rule: limit_induct)
      case (Init x)
        with assms show ?case by (auto simp add: wellformed_items_def)
    next
      case (Iterate p Y)
        from Iterate(1) have wellformed_Y: "wellformed_items Y"
          by (auto simp add: wellformed_items_def)
        then have "wellformed_items (Complete k (Predict k Y))"
          by (simp add: wellformed_items_Complete wellformed_items_Predict)
        then have "wellformed_items (Scan (Tokens k (\<T> k u) (\<J> k u)) k (Complete k (Predict k Y)))"
          apply (rule_tac wellformed_items_Scan)
          apply simp
          apply (simp add: Tokens_def)
          by (meson Sel_upper_bound TokensAt_subset_\<X> \<T>_subset_TokensAt subset_trans)
        then show ?case
          using Iterate.hyps(2) wellformed_items_def by blast
    qed
  }
  then show ?thesis
    using wellformed_items_def by blast
qed

lemma wellformed_items_\<J>_k_u_if_0: "wellformed_items (\<J> k 0) \<Longrightarrow> wellformed_items (\<J> k u)"
  apply (induct u)
  apply (simp)
  using wellformed_items_\<J>_induct_u by blast

lemma wellformed_items_natUnion: "(\<And> k. wellformed_items (I k)) \<Longrightarrow> wellformed_items (natUnion I)"
  by (auto simp add: natUnion_def wellformed_items_def)

lemma wellformed_items_\<I>_k_if_0: "wellformed_items (\<J> k 0) \<Longrightarrow> wellformed_items (\<I> k)"
  apply (simp)
  apply (rule wellformed_items_natUnion)
  using wellformed_items_\<J>_k_u_if_0 by blast

lemma wellformed_items_\<J>_\<I>: "wellformed_items (\<J> k u) \<and> wellformed_items (\<I> k)"
proof (induct k arbitrary: u)
  case 0
    show ?case
      using wellformed_\<J>_0_0 wellformed_items_\<I>_k_if_0 wellformed_items_\<J>_k_u_if_0 by blast
next
  case (Suc k)
    have 0: "wellformed_items (\<J> (Suc k) 0)"
      apply simp
      using Suc.hyps wellformed_items_\<pi> by auto
    then show ?case
      using wellformed_items_\<I>_k_if_0 wellformed_items_\<J>_k_u_if_0 by blast
qed

lemma wellformed_items_\<J>: "wellformed_items (\<J> k u)"
by (simp add: wellformed_items_\<J>_\<I>)

lemma wellformed_items_\<I>: "wellformed_items (\<I> k)"
using wellformed_items_\<J>_\<I> by blast

lemma funpower_consume_function:
  assumes law: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X) \<and> P (g X)"
  shows "P I \<Longrightarrow> P (funpower g n I) \<and> f (funpower g n I) = funpower h n (f I)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have S1: "P (funpower g n I)" and S2: "f (funpower g n I) = funpower h n (f I)"
    by auto
  have law1: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X)" using law by auto
  have law2: "\<And> X. P X \<Longrightarrow> P (g X)" using law by auto
  show ?case
    apply simp
    apply (subst law1[where X="funpower g n I"])
    apply (simp add: S1)
    apply (subst S2)
    apply auto
    apply (rule law2)
    apply (simp add: S1)
    done
qed

lemma limit_consume_function:
  assumes continuous: "continuous f"
  assumes law: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X) \<and> P (g X)"
  assumes setmonotone: "setmonotone g"
  shows "P I \<Longrightarrow> f (limit g I) = limit h (f I)"
proof -
  have 1: "f (limit g I) = f (natUnion (\<lambda>n. funpower g n I))"
    by (simp add: limit_def)
  have "chain (\<lambda>n. funpower g n I)" by (simp add: setmonotone setmonotone_implies_chain_funpower)
  from continuous_apply[OF continuous this]
  have swap: "f (natUnion (\<lambda>n. funpower g n I)) = natUnion (f \<circ> (\<lambda>n. funpower g n I))" by blast
  have "f o (\<lambda>n. funpower g n I) = (\<lambda> n. f (funpower g n I))" by auto
  also have "P I \<Longrightarrow> (\<lambda> n. f (funpower g n I)) = (\<lambda> n. funpower h n (f I))"
    by (metis funpower_consume_function[where P=P and f=f and g=g and h=h, OF law, simplified])
  ultimately have "P I \<Longrightarrow> f o (\<lambda>n. funpower g n I) = (\<lambda> n. funpower h n (f I))" by auto
  with swap have 2: "P I \<Longrightarrow> f (natUnion (\<lambda>n. funpower g n I)) = natUnion (\<lambda> n. funpower h n (f I))"
    by auto
  have 3: "natUnion (\<lambda> n. funpower h n (f I)) = limit h (f I)"
    by (simp add: limit_def)
  assume "P I"
  with 1 2 3 show ?thesis by auto
qed

lemma items_le_\<pi>_swap:
  assumes wellformed_I: "wellformed_items I"
  assumes T: "T \<subseteq> \<X> k"
  shows "items_le k (\<pi> k T I) = \<pi> k (empty_tokens T) (items_le k I)"
proof -
  let ?g = "(Scan T k) o (Complete k) o (Predict k)"
  let ?h = "(Scan (empty_tokens T) k) o (Complete k) o (Predict k)"
  have law1: "\<And> I. wellformed_items I \<Longrightarrow> items_le k (?g I) = ?h (items_le k I)"
    using LocalLexing.wellformed_items_Predict LocalLexing_axioms items_le_Complete
      items_le_Predict items_le_Scan by auto
  have law2: "\<And> I. wellformed_items I \<Longrightarrow> wellformed_items (?g I)"
    by (simp add: T wellformed_items_Complete wellformed_items_Predict wellformed_items_Scan)
  show ?thesis
    apply (subst \<pi>_functional)
    apply (subst limit_consume_function[where P="wellformed_items" and h="?h"])
    apply (simp add: items_le_pointwise pointbased_implies_continuous pointwise_implies_pointbased)
    using law1 law2 apply blast
    apply (simp add: \<pi>_step_regular regular_implies_setmonotone)
    apply (rule wellformed_I)
    apply (subst \<pi>_functional)
    apply blast
    done
qed

lemma items_le_idempotent: "items_le k (items_le k I) = items_le k I"
  using items_le_def by auto

lemma paths_le_idempotent: "paths_le k (paths_le k P) = paths_le k P"
  using paths_le_def by auto

lemma items_le_fix_D:
  assumes items_le_fix: "items_le k I = I"
  assumes x_dom: "x \<in> I"
  shows "item_end x \<le> k"
using items_le_def items_le_fix x_dom by blast

lemma remove_paths_le_in_subset_Gen:
  assumes "items_le k I = I"
  assumes "I \<subseteq> Gen P"
  shows "I \<subseteq> Gen (paths_le k P)"
proof -
  {
    fix x :: item
    assume x_dom: "x \<in> I"
    then have x_item_end:  "item_end x \<le> k" using assms items_le_fix_D by auto
    have "x \<in> Gen P" using assms x_dom by auto
    then obtain p where p: "p \<in> P \<and> pvalid p x" using Gen_implies_pvalid by blast
    have charslength_p: "charslength p \<le> k" using p pvalid_item_end x_item_end by auto
    then have "p \<in> paths_le k P" by (simp add: p paths_le_def)
    then have "x \<in> Gen (paths_le k P)" using Gen_def p by blast
  }
  then show ?thesis by blast
qed

lemma mono_Gen: "mono Gen"
  by (auto simp add: mono_def Gen_def)

lemma empty_tokens_idempotent: "empty_tokens (empty_tokens T) = empty_tokens T"
  by (auto simp add: empty_tokens_def)

lemma empty_tokens_is_filter: "empty_tokens T \<subseteq> T"
  by (auto simp add: empty_tokens_def)

lemma items_le_paths_le: "items_le k (Gen P) = Gen (paths_le k P)"
  using LocalLexing.Gen_def LocalLexing.items_le_def LocalLexing_axioms paths_le_def
  pvalid_item_end by auto

lemma bin_items_le[symmetric]: "bin I k = bin (items_le k I) k"
  by (auto simp add: bin_def items_le_def)

lemma TokensAt_items_le[symmetric]: "TokensAt k I = TokensAt k (items_le k I)"
  using TokensAt_def bin_items_le by blast

lemma by_length_paths_le[symmetric]: "by_length k P = by_length k (paths_le k P)"
  using by_length.simps paths_le_def by auto

lemma \<W>_paths_le[symmetric]: "\<W> P k = \<W> (paths_le k P) k"
  using \<W>_def by_length_paths_le by blast

theorem \<T>_equals_\<Z>_induct_step:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  shows "\<T> k (Suc u) = \<Z> k (Suc u)"
proof -
  have "TokensAt k (\<J> k u) = TokensAt k (items_le k (\<J> k u))"
    using TokensAt_items_le by blast
  also have "TokensAt k (items_le k (\<J> k u)) = TokensAt k (Gen (paths_le k (\<P> k u)))"
    using induct by auto
  ultimately have TokensAt_le: "TokensAt k (\<J> k u) = TokensAt k (Gen (paths_le k (\<P> k u)))"
    by auto
  have "TokensAt k (\<J> k u) = \<W> (\<P> k u) k"
    apply (subst TokensAt_le)
    apply (subst \<W>_paths_le[symmetric])
    apply (rule_tac thmD4[symmetric])
    using \<PP>_covers_\<P> paths_le_is_filter by blast
  then show ?thesis
    by (simp add: induct_tokens Tokens_def \<Y>_def)
qed

theorem thmD9:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  assumes k: "k \<le> length Doc"
  shows "items_le k (\<J> k (Suc u)) \<subseteq> Gen (paths_le k (\<P> k (Suc u)))"
proof -
  have t1: "items_le k (\<J> k (Suc u)) = items_le k (\<pi> k (\<T> k (Suc u)) (\<J> k u))"
    by auto
  have t2: "items_le k (\<pi> k (\<T> k (Suc u)) (\<J> k u)) =
    \<pi> k (empty_tokens (\<T> k (Suc u))) (items_le k (\<J> k u))"
    apply (subst items_le_\<pi>_swap)
    apply (simp add: wellformed_items_\<J>)
    using TokensAt_subset_\<X> \<T>_subset_TokensAt apply blast
    by blast
  have t3: "\<pi> k (empty_tokens (\<T> k (Suc u))) (items_le k (\<J> k u)) =
    \<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k u)))"
    using induct by auto
  have \<P>_subset: "\<P> k u \<subseteq> \<P> k (Suc u)" using subset_\<P>Suc by blast
  then have "paths_le k (\<P> k u) \<subseteq> paths_le k (\<P> k (Suc u))"
    by (simp add: mono_subset_elem paths_le_mono subsetI)
  with mono_Gen have "Gen (paths_le k (\<P> k u)) \<subseteq> Gen (paths_le k (\<P> k (Suc u)))"
    by (simp add: mono_subset_elem subsetI)
  then have t4: "\<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k u))) \<subseteq>
    \<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k (Suc u))))"
    by (rule monoD[OF mono_\<pi>])
  have \<T>_eq_\<Z>: "\<T> k (Suc u) = \<Z> k (Suc u)"
    using \<T>_equals_\<Z>_induct_step assms(1) induct_tokens by blast
  have t5: "\<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k (Suc u)))) \<subseteq>
    Gen (paths_le k (\<P> k (Suc u)))"
    apply (rule_tac remove_paths_le_in_subset_Gen)
    apply (subst items_le_\<pi>_swap)
    using wellformed_items_Gen apply blast
    using \<T>_eq_\<Z> \<Z>_subset_\<X> empty_tokens_is_filter apply blast
    apply (simp only: empty_tokens_idempotent paths_le_idempotent items_le_paths_le)
    apply (rule_tac thmD5)
    using items_le_is_filter items_le_paths_le apply blast
    apply (rule k)
    using \<T>_eq_\<Z> empty_tokens_is_filter by blast
  from t1 t2 t3 t4 t5 show ?thesis using subset_trans by blast
qed

end

end


theory bin_plus_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

(*hipster s plus *)

theorem x0 :
  "!! (x :: Bin) (y :: Bin) . (plus x y) = (plus y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      perfect/Safety_Perfect.thy
    Author:     Sven Linker

Distance and Lane change controller for cars with perfect sensors.
Safety theorem and invariance with respect to switching views.
*)

section\<open>Safety for Cars with Perfect Sensors\<close>
text\<open>
This section contains the definition of requirements for
lane change and distance controllers for cars, with the assumption
of perfect sensors. Using these definitions, we show that safety
is an invariant along all possible behaviour of cars.
\<close>

theory Safety_Perfect
  imports HMLSL_Perfect
begin

context hmlsl_perfect
begin
interpretation hmlsl : hmlsl "perfect :: cars \<Rightarrow> traffic \<Rightarrow> cars \<Rightarrow> real"
proof unfold_locales
  fix e ts c
  show " 0 < perfect e ts c"
    by (metis less_add_same_cancel2 less_trans perfect_def traffic.psGeZero
        traffic.sdGeZero)
qed

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

text\<open>
Safety in the context of HMLSL means the absence of overlapping
reservations. Using the somewhere modality, this is easy to formalise.
\<close>
abbreviation safe::"cars\<Rightarrow>\<sigma>"
  where "safe e \<equiv> \<^bold>\<forall> c. \<^bold>\<not>(c \<^bold>= e) \<^bold>\<rightarrow> \<^bold>\<not> \<^bold>\<langle>re(c) \<^bold>\<and> re(e) \<^bold>\<rangle>"

text\<open>
The distance controller ensures, that as long as the cars do not try
to change their lane, they keep their distance. More formally,
if the reservations of two cars do not overlap, they will also not
overlap after an arbitrary amount of time passed. Observe that
the cars are allowed to change their dynamical behaviour, i.e.,
to accelerate and brake.
\<close>

abbreviation DC::"\<sigma>"
  where "DC \<equiv> \<^bold>G(\<^bold>\<forall> c d. \<^bold>\<not>(c \<^bold>= d) \<^bold>\<rightarrow>
                   \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(d)\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<tau> \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(d)\<^bold>\<rangle>)"

text\<open>
To identify possibly dangerous situations during a lane change manoeuvre,
we use the \emph{potential collision check}. It allows us to identify
situations, where the claim of a car \(d\) overlaps with
any part of the car \(c\).
\<close>

abbreviation pcc::"cars \<Rightarrow> cars \<Rightarrow> \<sigma>"
  where "pcc c d \<equiv> \<^bold>\<not> (c \<^bold>= d) \<^bold>\<and> \<^bold>\<langle> cl(d) \<^bold>\<and> (re(c) \<^bold>\<or> cl(c)) \<^bold>\<rangle>"

text \<open>
The only restriction the lane change controller imposes onto the cars is
that in the case of a potential collision, they are not allowed to change
the claim into a reservation.
\<close>

abbreviation LC::"\<sigma>"
  where "LC \<equiv> \<^bold>G ( \<^bold>\<forall>d.( \<^bold>\<exists> c. pcc c d) \<^bold>\<rightarrow> \<^bold>\<box>r(d) \<^bold>\<bottom>)  "

text\<open>
The safety theorem is as follows. If the controllers of all
cars adhere to the specifications given by \(LC\) and \(DC\),
and we start with an initially safe traffic snapshot, then
all reachable traffic snapshots are also safe.
\<close>

theorem safety:"\<Turnstile>( \<^bold>\<forall>e. safe e ) \<^bold>\<and> DC \<^bold>\<and> LC \<^bold>\<rightarrow> \<^bold>G (\<^bold>\<forall> e. safe e)"
proof (rule allI|rule impI)+
  fix ts v ts'
  fix e c::cars
  assume assm:"ts,v \<Turnstile> ( \<^bold>\<forall>e. safe e ) \<^bold>\<and> DC \<^bold>\<and> LC"
  assume  abs:"ts \<^bold>\<Rightarrow> ts'"
  assume nequals: "ts,v \<Turnstile>\<^bold>\<not>(c \<^bold>=e)"
  from assm have init:"ts,v \<Turnstile> ( \<^bold>\<forall>e. safe e )" by simp
  from assm have DC :"ts,v \<Turnstile> DC" by simp
  from assm have LC: "ts,v \<Turnstile> LC" by simp
  from abs show "ts',move ts ts' v \<Turnstile>  \<^bold>\<not> \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle> "
  proof (induction)
    case (refl)
    have "move ts ts v = v" using traffic.move_nothing by simp
    thus ?case using init traffic.move_nothing nequals  by auto
  next
    case (evolve ts' ts'' )
    have local_DC:
      "ts',move ts ts' v \<Turnstile> \<^bold>\<forall> c d. \<^bold>\<not>(c \<^bold>= d) \<^bold>\<rightarrow>
                               \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(d)\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<tau> \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(d)\<^bold>\<rangle>"
      using "evolve.hyps" DC by simp
    show ?case
    proof
      assume e_def:" (ts'',move ts ts'' v \<Turnstile>  \<^bold>\<langle>re(c) \<^bold>\<and> re(e) \<^bold>\<rangle>)"
      from "evolve.IH"  and nequals have
        ts'_safe:"ts',move ts ts' v \<Turnstile> \<^bold>\<not>(c \<^bold>= e) \<^bold>\<and> \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>" by fastforce
      hence no_coll_after_evol:"ts',move ts ts' v \<Turnstile> \<^bold>\<box>\<^bold>\<tau> \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
        using local_DC by blast
      have move_eq:"move ts' ts'' (move ts ts' v) = move ts ts'' v"
        using "evolve.hyps" traffic.abstract.evolve traffic.abstract.refl
          traffic.move_trans
        by blast
      from no_coll_after_evol and "evolve.hyps" have
        "ts'',move ts' ts'' (move ts ts' v) \<Turnstile>  \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
        by blast
      thus False using e_def using  move_eq by fastforce
    qed
  next
    case (cr_res ts' ts'')
    have local_LC: "ts',move ts ts' v \<Turnstile>( \<^bold>\<forall>d.( \<^bold>\<exists> c. pcc c d) \<^bold>\<rightarrow> \<^bold>\<box>r(d) \<^bold>\<bottom>)"
      using LC "cr_res.hyps" by blast
    have "move ts ts' v = move ts' ts'' (move ts ts' v)"
      using traffic.move_stability_res "cr_res.hyps" traffic.move_trans
      move_stability_clm by auto
    hence move_stab: "move ts ts' v = move ts ts'' v"
      by (metis traffic.abstract.simps cr_res.hyps traffic.move_trans)
    show ?case
    proof (rule)
      assume e_def:" (ts'',move ts ts'' v \<Turnstile> \<^bold>\<langle>re(c) \<^bold>\<and> re(e) \<^bold>\<rangle>)"
      obtain d where d_def: "ts' \<^bold>\<midarrow>r(d) \<^bold>\<rightarrow> ts''" using "cr_res.hyps" by best
      have "d = e \<or> d \<noteq> e" by simp
      thus False
      proof
        assume eq:"d = e"
        hence e_trans:"ts' \<^bold>\<midarrow>r(e) \<^bold>\<rightarrow> ts''" using d_def by simp
        from e_def have "ts'',move ts ts'' v \<Turnstile> \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>" by auto
        hence "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
          using view.somewhere_leq
          by meson
        then obtain v' where v'_def:
          "(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
          by blast
        with backwards_res_act have "ts',v' \<Turnstile>   re(c) \<^bold>\<and> (re(e) \<^bold>\<or> cl(e))"
          using e_def  backwards_res_stab nequals
          by (metis (no_types, lifting) d_def eq)
        hence "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts',v' \<Turnstile> re(c) \<^bold>\<and> (re(e) \<^bold>\<or> cl(e)))"
          using  v'_def by blast
        hence "ts',move ts ts'' v \<Turnstile>\<^bold>\<langle> re(c) \<^bold>\<and> (re(e) \<^bold>\<or> cl(e)) \<^bold>\<rangle>"
          using view.somewhere_leq by meson
        hence "ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle> \<^bold>\<or> \<^bold>\<langle> re(c) \<^bold>\<and> cl(e)\<^bold>\<rangle> "
          using hmlsl.somewhere_and_or_distr by blast
        thus False
        proof
          assume assm':"ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
          have "ts',move ts ts' v \<Turnstile> \<^bold>\<not> (c \<^bold>= e)" using nequals by blast
          thus False using assm' cr_res.IH e_def move_stab by force
        next
          assume assm':"ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> re(c) \<^bold>\<and> cl(e)\<^bold>\<rangle>"
          hence "ts',move ts ts'' v \<Turnstile> \<^bold>\<not> (c \<^bold>=e) \<^bold>\<and> \<^bold>\<langle> re(c) \<^bold>\<and> cl(e)\<^bold>\<rangle>"
            using e_def nequals by force
          hence "ts',move ts ts'' v \<Turnstile>\<^bold>\<not> (c \<^bold>=e) \<^bold>\<and> \<^bold>\<langle> cl(e) \<^bold>\<and> (re(c) \<^bold>\<or> cl(c)) \<^bold>\<rangle>" by blast
          hence pcc:"ts',move ts ts'' v \<Turnstile> pcc c e" by blast
          have "ts',move ts ts'' v \<Turnstile>( \<^bold>\<exists> c. pcc c e) \<^bold>\<rightarrow> \<^bold>\<box>r(e) \<^bold>\<bottom>  "
            using local_LC move_stab by fastforce
          hence "ts',move ts ts'' v \<Turnstile> \<^bold>\<box>r(e) \<^bold>\<bottom>" using pcc by blast
          thus "ts'',move ts ts'' v \<Turnstile> \<^bold>\<bottom>" using e_trans by blast
        qed
      next
        assume neq:"d \<noteq> e"
        have "c=d \<or> c \<noteq> d" by simp
        thus False
        proof
          assume neq2:"c \<noteq> d"
          from e_def have "ts'',move ts ts'' v \<Turnstile> \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>" by auto
          hence "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
            using view.somewhere_leq
            by meson
          then obtain v' where v'_def:
            "(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
            by blast
          with backwards_res_stab have overlap: "ts',v' \<Turnstile> re(c) \<^bold>\<and> re(e)"
            using e_def  backwards_res_stab nequals neq2
            by (metis (no_types, lifting) d_def neq)
          hence unsafe2:"ts',move ts ts'' v \<Turnstile> \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
            using  nequals view.somewhere_leq v'_def by blast
          from cr_res.IH have "ts',move ts ts'' v \<Turnstile> \<^bold>\<not>\<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
            using move_stab by force
          thus False using unsafe2 by best
        next
          assume eq2:"c = d"
          hence e_trans:"ts' \<^bold>\<midarrow>r(c) \<^bold>\<rightarrow> ts''" using d_def by simp
          from e_def have "ts'',move ts ts'' v \<Turnstile> \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>" by auto
          hence "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
            using view.somewhere_leq
            by meson
          then obtain v' where v'_def:
            "(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
            by blast
          with backwards_res_act have "ts',v' \<Turnstile> (re(c) \<^bold>\<or> cl(c)) \<^bold>\<and> re(e)"
            using e_def  backwards_res_stab nequals
            by (metis (no_types, lifting) d_def eq2)
          hence "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts',v' \<Turnstile> (re(c) \<^bold>\<or> cl(c)) \<^bold>\<and> (re(e)))"
            using v'_def by blast
          hence "ts',move ts ts'' v \<Turnstile>\<^bold>\<langle> (re(c) \<^bold>\<or> cl(c)) \<^bold>\<and> (re(e) ) \<^bold>\<rangle>"
            using view.somewhere_leq by meson
          hence "ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle> \<^bold>\<or> \<^bold>\<langle> cl(c) \<^bold>\<and> re(e)\<^bold>\<rangle> "
            using hmlsl.somewhere_and_or_distr  by blast
          thus False
          proof
            assume assm':"ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
            have "ts',move ts ts'' v \<Turnstile> \<^bold>\<not> (c \<^bold>= e)" using nequals by blast
            thus False using assm' cr_res.IH e_def move_stab by fastforce
          next
            assume assm':"ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle> cl(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
            hence "ts',move ts ts'' v \<Turnstile> \<^bold>\<not> (c \<^bold>=e) \<^bold>\<and> \<^bold>\<langle> cl(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
              using e_def nequals by blast
            hence "ts',move ts ts'' v \<Turnstile>\<^bold>\<not> (c \<^bold>=e) \<^bold>\<and> \<^bold>\<langle> cl(c) \<^bold>\<and> (re(e) \<^bold>\<or> cl(e)) \<^bold>\<rangle>"
              by blast
            hence pcc:"ts',move ts ts'' v \<Turnstile> pcc e c" by blast
            have "ts',move ts ts'' v \<Turnstile>( \<^bold>\<exists> d. pcc d c) \<^bold>\<rightarrow> \<^bold>\<box>r(c) \<^bold>\<bottom>  "
              using local_LC move_stab by fastforce
            hence "ts',move ts ts'' v \<Turnstile> \<^bold>\<box>r(c) \<^bold>\<bottom>" using pcc by blast
            thus "ts'',move ts ts'' v \<Turnstile> \<^bold>\<bottom>" using e_trans by blast
          qed
        qed
      qed
    qed
  next
    case (cr_clm ts' ts'')
    have "move ts ts' v = move ts' ts'' (move ts ts' v)"
      using traffic.move_stability_clm cr_clm.hyps traffic.move_trans
      by auto
    hence move_stab: "move ts ts' v = move ts ts'' v"
      by (metis traffic.abstract.simps cr_clm.hyps traffic.move_trans)
    show ?case
    proof (rule)
      assume e_def:"(ts'',move ts ts'' v \<Turnstile>  \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>)"
      obtain d where d_def: "\<exists>n. (ts' \<^bold>\<midarrow>c(d,n) \<^bold>\<rightarrow> ts'')"
        using cr_clm.hyps by blast
      from this obtain n where n_def:" (ts' \<^bold>\<midarrow>c(d,n) \<^bold>\<rightarrow> ts'')"  by blast
      from e_def have "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using view.somewhere_leq by fastforce
      then obtain v' where v'_def:"(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        by blast
      then have " (ts',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using n_def backwards_c_res_stab by blast
      then have "ts', move ts ts'' v \<Turnstile> \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
        using v'_def view.somewhere_leq by meson
      thus False using cr_clm.IH move_stab e_def nequals by fastforce
    qed
  next
    case (wd_res ts' ts'')
    have "move ts ts' v = move ts' ts'' (move ts ts' v)"
      using traffic.move_stability_wdr wd_res.hyps traffic.move_trans
      by auto
    hence move_stab: "move ts ts' v = move ts ts'' v"
      by (metis traffic.abstract.simps wd_res.hyps traffic.move_trans)
    show ?case
    proof (rule )
      assume e_def: " (ts'',move ts ts'' v \<Turnstile>  \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>)"
      obtain d where d_def:"\<exists>n. (ts' \<^bold>\<midarrow>wdr(d,n) \<^bold>\<rightarrow> ts'')"
        using wd_res.hyps by blast
      from this obtain n where n_def:" (ts' \<^bold>\<midarrow>wdr(d,n) \<^bold>\<rightarrow> ts'')"  by blast
      from e_def have "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using view.somewhere_leq by fastforce
      then obtain v' where v'_def:"(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        by blast
      then have " (ts',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using n_def backwards_wdr_res_stab by blast
      then have "  (ts',move ts ts'' v \<Turnstile>  \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>)"
        using v'_def view.somewhere_leq by meson
      thus False using wd_res.IH move_stab by fastforce
    qed
  next
    case (wd_clm ts' ts'')
    have "move ts ts' v = move ts' ts'' (move ts ts' v)"
      using traffic.move_stability_wdc wd_clm.hyps traffic.move_trans
      by auto
    hence move_stab: "move ts ts' v = move ts ts'' v"
      by (metis traffic.abstract.simps wd_clm.hyps traffic.move_trans)
    show ?case
    proof (rule)
      assume e_def: " (ts'',move ts ts'' v \<Turnstile>  \<^bold>\<langle>re(c) \<^bold>\<and> re(e) \<^bold>\<rangle>)"
      obtain d where d_def: " (ts' \<^bold>\<midarrow>wdc(d) \<^bold>\<rightarrow> ts'')"
        using wd_clm.hyps by blast
      from e_def have "\<exists>v'. (v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using view.somewhere_leq by fastforce
      then obtain v' where v'_def:"(v' \<le> move ts ts'' v) \<and> (ts'',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        by blast
      then have " (ts',v' \<Turnstile> re(c) \<^bold>\<and> re(e))"
        using d_def backwards_wdc_res_stab by blast
      hence "ts',move ts ts'' v \<Turnstile> \<^bold>\<langle>re(c) \<^bold>\<and> re(e)\<^bold>\<rangle>"
        using v'_def view.somewhere_leq by meson
      thus False using wd_clm.IH move_stab by fastforce
    qed
  qed
qed

text\<open>
While the safety theorem was only proven for a single car, we can
show that the choice of this car is irrelevant. That is, if we have
a safe situation, and switch the perspective to another car,
the resulting situation is also safe.
\<close>

lemma safety_switch_invariant:"\<Turnstile>(\<^bold>\<forall>e. safe(e)) \<^bold>\<rightarrow>  \<^bold>@c (\<^bold>\<forall>e. safe(e))"
proof (rule allI|rule impI)+
  fix ts v v'
  fix e d :: cars
  assume assm: "ts,v \<Turnstile>  \<^bold>\<forall>e. safe(e)"
    and v'_def:"(v=c>v')"
    and nequals:"ts,v \<Turnstile> \<^bold>\<not>(d \<^bold>=  e)"
  show "ts,v' \<Turnstile>  \<^bold>\<not> \<^bold>\<langle>re(d) \<^bold>\<and> re(e)\<^bold>\<rangle>"
  proof(rule)
    assume e_def: "ts,v' \<Turnstile>  \<^bold>\<langle>re(d) \<^bold>\<and> re(e)\<^bold>\<rangle>"
    from e_def obtain v'sub where v'sub_def:
      "(v'sub \<le> v') \<and> (ts,v'sub \<Turnstile> re(d) \<^bold>\<and> re(e))"
      using view.somewhere_leq by fastforce
    have "own v' = c" using v'_def view.switch_def by auto
    hence "own v'sub = c" using v'sub_def less_eq_view_ext_def by auto
    obtain vsub where vsub:"(vsub =c> v'sub) \<and> (vsub \<le> v)"
      using v'_def v'sub_def view.switch_leq by blast
    from v'sub_def and vsub have "ts,vsub \<Turnstile> \<^bold>@c re(d)"
      by (metis view.switch_unique)
    hence vsub_re_d:"ts,vsub \<Turnstile> re(d)" using at_res_inst by blast
    from v'sub_def and vsub have "ts,vsub \<Turnstile> \<^bold>@c re(e)"
      by (metis view.switch_unique)
    hence vsub_re_e:"ts,vsub \<Turnstile> re(e)" using at_res_inst by blast
    hence "ts,vsub\<Turnstile>re(d) \<^bold>\<and> re(e)" using vsub_re_e vsub_re_d by blast
    hence "ts,v \<Turnstile>\<^bold>\<langle> re(d) \<^bold>\<and> re(e) \<^bold>\<rangle>"
      using vsub view.somewhere_leq by fastforce
    then show False using assm nequals by blast
  qed
qed
end
end


theory ex_3_2
  imports Main
begin
inductive palindrome ::"'a list \<Rightarrow> bool" where
"palindrome []" |
"palindrome [a]" |
"palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

theorem palindrome:"palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule:palindrome.induct)
  by (auto)
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul3_comm23
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3 x z y))"
  oops

end


theory manually_solved_cases
  imports
    ODE_Solve_Keyword
begin

(* This solves \<open>ode_solve_thm "\<lambda> (t::real) x. tan t" "{t. cos t > 0}"\<close>*)
lemma "((\<lambda>t. C0 + ln (inverse (((tan t)\<^sup>2 + 1) ^ 1)) * - 1 / 2) solves_ode (\<lambda>t x. tan t)) {t. 0 < cos t} \<real>"
  apply ode_cert
proof -
  fix x :: real
  have f1: "\<And>r ra. (r::real) - - ra = ra - - r"
    by simp
  have f2: "\<And>r ra rb. (r::real) * ra - - (rb * ra) = (r - - rb) * ra"
    by (metis diff_minus_eq_add distrib_right)
  have f3: "\<And>r ra. (r::real) * (r * ra) = r\<^sup>2 * ra"
    by (simp add: power2_eq_square)
  have "cos x * ((sin x - - sin x) * (((cos x)\<^sup>2)\<^sup>2 * ((sin x)\<^sup>2 - - (cos x)\<^sup>2))) = cos x * ((sin x - - sin x) * ((cos x)\<^sup>2)\<^sup>2)"
    by simp
  then have "cos x * (cos x * (cos x * (cos x * (cos x * (cos x * (cos x * (sin x - - sin x)) - - (sin x * (sin x * (sin x - - sin x)))))))) = cos x * (cos x * (cos x * (cos x * (cos x * (sin x - - sin x)))))"
    using f3 f2 f1 by (metis (no_types) mult.commute mult.left_commute)
  then show "cos x * (cos x * (cos x * (cos x * (cos x * (cos x * (cos x * (sin x * 2))))))) + cos x * (cos x * (cos x * (cos x * (cos x * (sin x * (sin x * (sin x * 2))))))) = cos x * (cos x * (cos x * (cos x * (cos x * (sin x * 2)))))"
    by (simp add: distrib_left)
qed

(* This solves \<open>ode_cert "\<lambda> (t::real) x. 1/(2*x-1)" "{t. t> 0}"\<close>*)
lemma "((\<lambda> t.((t :: real) * arcsin(t) + (C0::real) + (t^2 * -1 + 1) powr (1/2))) solves_ode (\<lambda>t x. arcsin t)) {-1<..<1} \<real>"
  apply ode_cert
   apply (smt mult_less_cancel_right2 mult_minus_left)
  apply simp
proof -
  have "\<And>x. - 1 < x \<and> x < 1 \<Longrightarrow> x * inverse (sqrt (1 - x\<^sup>2)) = (1 - x * x) powr (1 / 2) * x / ( abs(1 - x * x) )"
    apply (simp add: power2_eq_square powr_half_sqrt square_le_1)
    apply (smt divide_inverse power2_eq_square powr_half_sqrt real_divide_square_eq real_sqrt_mult_self square_le_1)
    done
  thus "\<And>x. - 1 < x \<and> x < 1 \<Longrightarrow> x * inverse (sqrt (1 - x\<^sup>2)) = (1 - x * x) powr (1 / 2) * x / (1 - x * x)"
    by (smt power2_eq_square square_le_1)
qed

(*This solves \<open>ode_cert "\<lambda> (t::real) x. t powr (sqrt 2)" "{0<..}"\<close>*)
theorem "((\<lambda>t. 2 powr (1 / 2) * (t :: real) * t powr 2 powr (1 / 2) * inverse ((2 powr (1 / 2) + 2) ^ 1) +(C0 :: real)) solves_ode (\<lambda>t x. t powr sqrt 2)) {0<..} \<real>"
  apply ode_cert
    apply (smt powr_gt_zero)
   apply (rule has_vector_derivative_eq_rhs)
    apply (rule derivative_intros; (simp add: field_simps)?)+
   apply (simp add: field_simps)+
  apply (simp add: powr_half_sqrt)
  apply (metis add.commute add_pos_pos distrib_right less_numeral_extra(3) mult.commute nonzero_mult_div_cancel_right real_sqrt_gt_0_iff zero_less_numeral)
  done

end


theory MapCompStudyClean
imports VDMToolkit
begin

(* { d |-> r | d in set {1,2,3::nat}, r in set {2,4,6::nat} & r = d*2 } *)
lemma mapComp1: "(\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2,3::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r \<in> {2,4,6::VDMNat} \<and> r = d*2))
          else None) =
  [1 \<mapsto> 2, 2 \<mapsto> 4, 3 \<mapsto> 6]"
  unfolding inv_VDMNat_def
  apply rule
  apply (simp split:if_splits)
  apply (rule+, simp_all)
  apply (rule+, simp_all)
  by auto

definition
  mapComp1 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "mapComp1 \<equiv> (\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2::VDMNat} . inv_VDMNat d \<and> inv_VDMNat r \<and> r \<in> {2,4,6::VDMNat} \<and> dummy = d \<and> r = d*2))
          else None)"

lemma "x \<notin> {1,2,3::VDMNat} \<Longrightarrow>  mapComp1 x = None"
  by (simp add: mapComp1_def inv_VDMNat_def)

lemma "\<not> inv_VDMNat x  \<Longrightarrow> mapComp1  x = None"
  by (simp add: mapComp1_def inv_VDMNat_def)

definition
  mapComp2 :: "VDMNat \<rightharpoonup> VDMNat1"
  where
  "mapComp2 \<equiv> (\<lambda> dummy::VDMNat . if (\<exists> d \<in> {1,2,3::VDMNat} . \<exists> r \<in> {2,4,6::VDMNat} . inv_VDMNat d \<and> inv_VDMNat1 r \<and> dummy = d \<and> r = d*2) then
              Some (THE r . (\<exists> d \<in> {1,2, 3::VDMNat} . inv_VDMNat d \<and> inv_VDMNat1 r \<and> r \<in> {2,4,6::VDMNat} \<and> dummy = d \<and> r = d*2))
          else None)"

lemma "x \<notin> dom mapComp2  \<Longrightarrow>  mapComp2 x = None"
  by (simp add: domIff mapComp2_def)

lemma "dom mapComp2 = {1,2,3::VDMNat}"
  unfolding dom_def mapComp2_def inv_VDMNat1_def inv_VDMNat_def
  by (simp split:if_splits, safe)

lemma "rng mapComp2 = {2,4,6::VDMNat}"
  unfolding ran_def rng_def mapComp2_def inv_VDMNat1_def inv_VDMNat_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
   apply (elim exE conjE disjE, simp_all)
     apply fastforce
  apply fastforce
   apply fastforce
  by (smt (z3) semiring_norm(83) the_equality verit_eq_simplify(14) zero_le_numeral)

text \<open>Isabelle maps are similar to VDMs, but with some significant differences worth observing.

      If the filtering is not unique (i.e. result is not a function), then the @{term "THE x . P x"} expression
      might lead to (undefined) unexpected results. In Isabelle maps, repetitions is equivalent to overriding,
      so that @{lemma "[1::nat \<mapsto> 2, 1 \<mapsto> 3] 1 = Some 3" by simp}.

      In various VDMToolkit definitions, we default to @{term undefined} in case where the situation is out of hand,
      hence, proofs will fail, and users will know that @{term undefined} being reached means some earlier problem has
      occurred.
    \<close>

text \<open>Type bound map comprehension cannot filter for type invariants, hence won't have @{term undefined} results.
      This corresponds to the VDMSL expression
      %
      \begin{vdmssl}
        { domexpr(d) |-> rngexpr(d, r) | d:S, r: T & P(d, r) }
      \end{vdmsl}
      %
      where the maplet expression can be just variables or functions over the domain/range input(s).

      VDM also issues a proof obligation for type bound maps (i.e. avoid it please!) to ensure the resulting map is finite.
      Concretely, the example below generates the corresponding proof obligation:
      %
      \begin{vdmsl}
      	ex: () -> map nat to nat
	      ex() == { x+y |-> 10 | x: nat, y in set {4,5,6} & x < 10 };

        exists finmap1: map nat to (map (nat1) to (nat1)) &
            forall x:nat, y in set {4, 5, 6} & (x < 10) =>
              exists findex2 in set dom finmap1 &
                finmap1(findex2) = {(x + y) |-> 10}
      \end{vdmsl}
     \<close>
definition
  mapCompTypeBound :: "('a \<Rightarrow> \<bool>) \<Rightarrow> ('b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where
  "mapCompTypeBound inv_S inv_T domexpr rngexpr pred \<equiv>
        (\<lambda> dummy::'a .
            if (\<exists> d r . inv_S d \<and> inv_T r \<and> dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r) then
                Some (THE r . inv_T r \<and> (\<exists> d . dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r))
              else
                None
        )"

value "[1::nat \<mapsto> 2::nat, 3 \<mapsto> 3] 10"
text \<open>Set bound map comprehension can filter bound set for their elements invariants.
      This corresponds to the VDMSL expression
      % TODO use x and y instead of d and r?
      \begin{vdmssl}
        { domexpr(d, r) |-> rngexpr(d, r) | d in set S, r in set T & pred(d, r) }
        domexpr: S * T -> S
        rngexpr: S * T -> T
        pred   : S * T -> bool
      \end{vdmsl}
      %
      If the types of domexpr or rngexpr are different from S or T then this will not work!
      %
      If the filtering is not unique (i.e. result is not a function), then the @{term "THE x . P x"} expression
      might lead to (undefined) unexpected results. In Isabelle maps, repetitions is equivalent to overriding,
      so that @{lemma "[1::nat \<mapsto> 2::nat, 1 \<mapsto> 3] 1 = Some 3" by simp}.
     \<close>
value "((1::real) / (0::real)) + 5"
value "(3 - (5::nat))"
definition
  mapCompSetBound :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> \<bool>) \<Rightarrow> ('b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> \<bool>) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where
  "mapCompSetBound S T inv_S inv_T domexpr rngexpr pred \<equiv>
        (\<lambda> dummy::'a .
            \<comment> \<open>In fact you have to check the inv_Type of domexpr and rngexpr!!!\<close>
            if inv_VDMSet' inv_S S \<and> inv_VDMSet' inv_T T then
              if (\<exists> r \<in> T . \<exists> d \<in> S . dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r) then
                Some (THE r . r \<in> T \<and> inv_T r \<and> (\<exists> d \<in> S . dummy = domexpr d r \<and> r = rngexpr d r \<and> pred d r))
              else
                \<comment> \<open>This is for map application outside its domain error, VDMJ 4061 \<close>
                None
            else
              \<comment> \<open>This is for type invariant violation errors, VDMJ ???? @NB?\<close>
              undefined
        )"

text \<open>Identity functions to be used for the dom/rng expression functions for the case they are variables.\<close>
definition
  domid :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
  where
  "domid \<equiv> (\<lambda> d . (\<lambda> r . d))"

definition
  rngid :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  where
  "rngid \<equiv> (\<lambda> d . id)"

text \<open>Constant function to be used for the rng expression function for the case they are constants.\<close>
definition
  rngcnst :: "'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  where
  "rngcnst v \<equiv> (\<lambda> d . (\<lambda> r . v))"

definition
  truecnst :: "'a \<Rightarrow> 'b \<Rightarrow> \<bool>"
  where
  "truecnst \<equiv> (\<lambda> d . inv_True)"

lemma domidI[simp]: "domid d r = d"
  by (simp add: domid_def)

lemma rngidI[simp]: "rngid d r = r"
  by (simp add: rngid_def)

lemma rngcnstI[simp]: "rngcnst v d r = v"
  by (simp add: rngcnst_def)

lemmas maplet_defs = domid_def rngid_def rngcnst_def id_def truecnst_def inv_True_def
lemmas rng_defs = rng_def ran_def
lemmas mapCompSetBound_defs = mapCompSetBound_def inv_VDMSet'_def inv_VDMSet_def maplet_defs rng_defs
lemmas mapCompTypeBound_defs = mapCompTypeBound_def maplet_defs rng_defs

(*On the explicit (narrower/declared) type, add inv_VDMNat1
  v98: map nat to nat1 = { d \<mapsto> r | d in set {1,2,3}, r in set {2,4,6} & r = d*2 } *)
definition
  ex1 :: "VDMNat \<rightharpoonup> VDMNat1"
  where
  "ex1 \<equiv> mapCompSetBound {1,2,3::VDMNat} {2,4,6::VDMNat} inv_VDMNat inv_VDMNat1 domid rngid (\<lambda> d r . r = d*2)"

lemmas ex1_defs = ex1_def mapCompSetBound_defs inv_VDMNat1_def inv_VDMNat_def

\<comment> \<open>making sure the encoding is indeed correct wrt to the example\<close>
lemma "mapComp2 = ex1"
  unfolding ex1_defs mapComp2_def domid_def rngid_def rngcnst_def
  apply (simp)
  apply (rule, simp, safe)
  by meson+

lemma ex1_none: "x \<notin> dom ex1  \<Longrightarrow> ex1 x = None"
  by (simp add: domIff)

lemma ex1_dom: "dom ex1 = {1,2,3}"
  unfolding dom_def ex1_defs
  by (simp split:if_splits, safe)

lemma ex1_rng:"rng ex1 = {2,4,6}"
  unfolding rng_defs ex1_defs
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
  (* apply (elim exE conjE impE)*) (* this will be fiddly! *)
  apply (elim exE conjE disjE, simp_all)
     apply (fastforce, fastforce, fastforce)
  by (smt (z3) semiring_norm(83) the_equality verit_eq_simplify(14) zero_le_numeral)

(*@TODO add invariant failure to undefined tests! *)

lemma ex1_map: "x \<in> dom ex1 \<Longrightarrow> ex1 x = Some (2*x)"
  unfolding ex1_defs
  apply (simp split:if_splits, safe, force+)
  thm option.discI
  by (metis option.discI)

(*On the implicit (wider/presumed) type, add inv_VDMNat; these funny binds are tricky!
  v98 = { x+y |-> 10 | x in set {1,2,3}, y in set {4,5,6} } *)
definition
  ex2 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex2 \<equiv> mapCompSetBound {1,2,3::VDMNat} {4,5,6::VDMNat} inv_VDMNat inv_VDMNat (\<lambda> x . (\<lambda> y . x+y)) (rngcnst 10) truecnst"

lemmas ex2_defs = ex2_def mapCompSetBound_defs inv_VDMNat_def

lemma ex2_none: "x \<notin> dom ex2  \<Longrightarrow> ex2 x = None"
  by (simp add: domIff)

lemma ex2_dom: "dom ex2 = {5,6,7,8,9}"
  unfolding ex2_defs
  apply (simp split:if_splits)
  oops

definition
  ex2' :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex2' \<equiv> mapCompSetBound { x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} } {10::VDMNat}
                inv_VDMNat inv_VDMNat domid (rngcnst 10) truecnst"

lemmas ex2'_defs = ex2'_def mapCompSetBound_defs inv_VDMNat_def

lemma ex2'_none: "x \<notin> dom ex2'  \<Longrightarrow> ex2' x = None"
  unfolding ex2'_defs
  by (simp add: domIff)

lemma ex2'_dom: "dom ex2' = {5,6,7,8,9}"
  unfolding ex2'_defs
  apply (simp split:if_splits, safe) oops

lemma ex2'_dom_finite: "finite { x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} }"
  by (simp add: finite_image_set2)

lemma ex2'_dom_clearer: "{ x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} } = {5..9::VDMNat}"
  apply (safe, simp_all)
  by presburger

lemma ex2'_dom_inv: "inv_SetElems ((\<le>) (0::VDMNat)) {5..(9::VDMNat)}"
  unfolding inv_SetElems_def
  by (safe,simp)

lemma ex2'_dom_inv': "inv_SetElems inv_VDMNat {5..9}"
  unfolding inv_SetElems_def inv_VDMNat_def
  by (safe,simp)

lemma ex2'_dom: "dom ex2' = {5,6,7,8,9}"
  unfolding ex2'_def mapCompSetBound_def inv_VDMSet'_def inv_VDMSet_def truecnst_def
  apply (simp only: ex2'_dom_finite ex2'_dom_clearer, simp split:if_splits add: ex2'_dom_inv' inv_VDMNat_def)
  unfolding domid_def rngcnst_def inv_True_def inv_VDMNat_def
  apply (safe, simp_all)
  thm option.distinct
  by (smt (z3) option.distinct(1))

lemma ex2'_rng:"rng ex2' = {10}"
  unfolding rng_defs ex2'_def mapCompSetBound_def inv_VDMSet'_def inv_VDMSet_def truecnst_def
  apply (simp only: ex2'_dom_finite ex2'_dom_clearer, simp split:if_splits add: ex2'_dom_inv' inv_VDMNat_def)
  by (safe, simp_all, force+)

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_defs (* don't expand inv_VDMNat *)
  apply (simp split:if_splits)
  (* complex domain patterns lead to loads of cases Jeez! no safe *)
  apply (intro conjI impI, force) oops

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  (* complex domain patterns lead to loads of cases Jeez! no safe *)
  apply (intro conjI impI)
  find_theorems intro name:the
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
  apply (simp add: inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def) (* clearly true by contradiction, but finite is struggling *)
  oops

lemma l_finite_setcomp_finite[simp]: "finite S \<Longrightarrow> finite T \<Longrightarrow> finite { P x y | x y . x \<in> S \<and> y \<in> T }"
  by (simp add: finite_image_set2)

thm finite_image_set2 finite_subset
lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_defs
  apply (insert l_finite_setcomp_finite[of _ _ "\<lambda> x y . x+y"]) (* lemma above not quite in right shape *)
  oops

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  apply (intro conjI impI)
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
  (*apply (smt (z3) Collect_cong atLeastAtMost_iff ex2'_dom_clearer ex2'_dom_finite mem_Collect_eq) *)(* horrible! *)
  apply (elim impE)
     apply (simp add: inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def inv_SetElems_def)
  apply (rule conjI)
  using ex2'_dom_finite apply force
     apply fastforce
  oops

lemma l_invVDMSet_finite[simp]: "finite S \<Longrightarrow> inv_SetElems inv_T S \<Longrightarrow> inv_VDMSet' inv_T S"
  by (simp add: inv_VDMSet'_def)

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  apply (intro conjI impI, simp)
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
    apply (erule impE)
  using ex2'_dom_clearer ex2'_dom_inv' apply auto[1]
  using inv_VDMNat_def apply auto[1]
   apply (smt (verit, del_insts) atLeastAtMost_iff ex2'_dom_clearer l_map_dom_ran)
(*  by (smt (z3) Collect_cong atLeastAtMost_iff ex2'_dom_clearer ex2'_dom_finite finite.emptyI finite.insertI inv_SetElems_def inv_VDMNat_def l_invVDMSet_finite mem_Collect_eq singletonD) *)
  apply (erule impE)
  using ex2'_dom_clearer ex2'_dom_inv' apply force
  using inv_VDMNat_def by auto

(* more direct binds even if with range expressions it's fine. UNIV isn't finite! DUH
   = { x |-> x+5 | x in set {1,2,3,4} & x > 2 } *)
definition
  ex3 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex3 \<equiv> mapCompSetBound {1,2,3,4::VDMNat} UNIV inv_VDMNat inv_VDMNat domid (\<lambda> x . (\<lambda> y . x + 5)) (\<lambda> x . (\<lambda> y . x > 2))"

lemmas ex3_defs = ex3_def mapCompSetBound_defs inv_VDMNat_def

lemma ex3_none: "x \<notin> dom ex3  \<Longrightarrow> ex3 x = None"
  by (simp add: domIff)

lemma ex3_dom: "dom ex3 = {5,6,7,8,9}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe)
  (* Nice example of how it goes "wrong" with undefined! *)
  oops

lemma ex3_dom: "dom ex3 = {1,2,3,4}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe) oops
  (* Nice example of how it goes "wrong" with undefined! *)

lemma ex3_dom: "dom ex3 = {3,4}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe) oops
  (* Nice example of how it goes "wrong" with undefined! *)

(* more direct binds even if with range expressions it's fine.
   = { x |-> x+5 | x in set {1,2,3,4} & x > 2 } *)
definition
  ex3' :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex3' \<equiv> mapCompSetBound {1,2,3,4::VDMNat} { x + 5 | x . x \<in> {1,2,3,4::VDMNat} } inv_VDMNat inv_VDMNat domid (\<lambda> x . (\<lambda> y . x + 5)) (\<lambda> x . (\<lambda> y . x > 2))"

lemmas ex3'_defs = ex3'_def mapCompSetBound_defs inv_VDMNat_def

lemma ex3'_none: "x \<notin> dom ex3'  \<Longrightarrow> ex3' x = None"
  by (simp add: domIff)

lemma ex3'_dom: "dom ex3' = {3,4}"
  unfolding ex3'_def mapCompSetBound_defs inv_SetElems_def inv_VDMNat_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all add: dom_def split:if_splits)
  by fastforce+

lemma ex3'_dom': "dom ex3' = {3,4}"
  unfolding ex3'_defs
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all add: dom_def split:if_splits)
  using inv_SetElems_def by fastforce+

lemma ex3'_rng: "rng ex3' = {8,9}"
  unfolding ex3'_defs inv_SetElems_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI)
   apply (simp_all, safe, simp_all)
       apply (rule+, force, force, force, force, force, force, force)
  apply (rule_tac x=3 in exI, force)
  by (rule_tac x=4 in exI, force)

lemma ex3'_map: "x \<in> dom ex3' \<Longrightarrow> ex3' x = Some (x+5)"
  unfolding ex3'_defs
  apply (simp split:if_splits, safe, force)
          apply (linarith, force)
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def by fastforce

(* okay: dead simple ones
   = { x |-> 5 | x in set {1,2,3,4} } *)
definition
  ex4 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex4 \<equiv> mapCompSetBound {1,2,3,4::VDMNat} { 5::VDMNat } inv_VDMNat inv_VDMNat domid (rngcnst 5) truecnst"

lemmas ex4_defs = ex4_def mapCompSetBound_defs inv_VDMNat_def

lemma ex4_none: "x \<notin> dom ex4  \<Longrightarrow> ex4 x = None"
  by (simp add: domIff)

lemma ex4_dom: "dom ex4 = {1,2,3,4}"
  unfolding ex4_def mapCompSetBound_defs inv_SetElems_def inv_VDMNat_def
  apply (simp split:if_splits)
  by (intro equalityI subsetI, simp_all add: dom_def split:if_splits)

lemma ex4_rng: "rng ex4 = {5}"
  unfolding ex4_defs inv_SetElems_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, force, simp)
  by (rule_tac x=1 in exI, fastforce)

lemma ex4_map: "x \<in> dom ex4  \<Longrightarrow> ex4 x = Some 5"
  unfolding ex4_defs
  apply (simp split:if_splits, safe, force+)
  by (meson option.distinct(1))
(* for simple domain binds, you get simple enough proofs *)

lemma "inv_VDMSet' inv_S S \<Longrightarrow>
      dom (mapCompSetBound S T inv_S inv_T domexpr rngexpr pred)
      =
      { x . inv_S x \<and> x \<in> S \<and> (\<exists> r . x = domexpr d r \<and> pred d r) }"
  unfolding mapCompSetBound_def
  apply safe
     apply (simp_all split:if_splits)
        apply safe
  nitpick
  oops

end


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_S1 imports System_L1 begin

text \<open>System S1 from Boleslaw Sobocinski: Axiomatization of a Conjunctive-Negative Calculus
                                          of Propositions (1954)\<close>

text \<open>Derivations are taken from: On Axiom Systems of Propositional Calculi. XI
                                  by Kashiko Tanaka (1965)\<close>

inductive S1 (\<open>\<SS>\<^sub>1\<close>) where
  S1_MP: \<open>\<SS>\<^sub>1 q\<close> if \<open>\<SS>\<^sub>1 p\<close> and \<open>\<SS>\<^sub>1 (p \<rightarrow> q)\<close> |
  S1_1:  \<open>\<SS>\<^sub>1 ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close> |
  S1_2:  \<open>\<SS>\<^sub>1 (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close> |
  S1_3:  \<open>\<SS>\<^sub>1 (((\<sim> p) \<rightarrow> r) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r)))\<close>

lemma S1_4: \<open>\<SS>\<^sub>1 ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((q \<rightarrow> p) \<rightarrow> (q \<rightarrow> r)))\<close>
  using S1_1 S1_3 S1_MP by metis

lemma S1_5: \<open>\<SS>\<^sub>1 ((q \<rightarrow> p) \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close>
  using S1_2 S1_4 S1_MP by metis

lemma S1_6: \<open>\<SS>\<^sub>1 ((\<sim> p) \<rightarrow> (s \<rightarrow> (p \<rightarrow> q)))\<close>
  using S1_1 S1_5 S1_MP by metis

lemma S1_7: \<open>\<SS>\<^sub>1 ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using S1_3 S1_5 S1_6 S1_MP by metis

lemma S1_8: \<open>\<SS>\<^sub>1 (q \<rightarrow> ((q \<rightarrow> p) \<rightarrow> (r \<rightarrow> p)))\<close>
  using S1_5 S1_7 S1_MP by metis

lemma S1_9: \<open>\<SS>\<^sub>1 ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S1_3 S1_6 S1_8 S1_MP by metis

lemma S1_10: \<open>\<SS>\<^sub>1 ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> (p \<rightarrow> q)))\<close>
  using S1_2 S1_3 S1_6 S1_MP by metis

lemma S1_11: \<open>\<SS>\<^sub>1 ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> q))\<close>
  using S1_4 S1_10 S1_MP by metis

lemma S1_12: \<open>\<SS>\<^sub>1 ((q \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> r))\<close>
  using S1_4 S1_11 S1_MP by metis

lemma S1_13: \<open>\<SS>\<^sub>1 (p \<rightarrow> (q \<rightarrow> p))\<close>
  using S1_2 S1_12 S1_MP by metis

lemma S1_14: \<open>\<SS>\<^sub>1 (p \<rightarrow> p)\<close>
  using S1_12 S1_13 S1_MP by metis

lemma S1_15: \<open>\<SS>\<^sub>1 (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close>
  using S1_1 S1_7 S1_MP by metis

lemma S1_16: \<open>\<SS>\<^sub>1 ((\<sim> (\<sim> p)) \<rightarrow> p)\<close>
  using S1_3 S1_13 S1_14 S1_15 S1_MP by metis

lemma S1_17: \<open>\<SS>\<^sub>1 (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close>
  using S1_3 S1_14 S1_16 S1_MP by metis

theorem S1_iff_L1: \<open>\<SS>\<^sub>1 p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_S1_1: \<open>\<turnstile> ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close> for p q
    using L1_completeness by simp
  have L1_S1_2: \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    using L1_completeness by simp
  have L1_S1_3: \<open>\<turnstile> (((\<sim> p) \<rightarrow> r) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r)))\<close> for p q r
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<SS>\<^sub>1 p\<close>
    using that by (induct) (metis MP, metis L1_S1_1, metis L1_S1_2, metis L1_S1_3)
  show \<open>\<SS>\<^sub>1 p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis S1_MP, metis S1_9, metis S1_17, metis S1_15)
qed

theorem S1_soundness: \<open>\<SS>\<^sub>1 p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: S1.induct) auto

theorem S1_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<SS>\<^sub>1 p\<close>
  using S1_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<SS>\<^sub>1 p\<close>
  unfolding valid_def using S1_soundness S1_completeness by blast

lemmas S1 = S1.intros main

end