(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
chapter \<open>Types\<close>
theory OCL_Types
  imports OCL_Basic_Types Errorable Tuple
begin

(*** Definition *************************************************************)

section \<open>Definition\<close>

text \<open>
  Types are parameterized over classes.\<close>

type_synonym telem = String.literal

datatype (plugins del: size) 'a type =
  OclSuper
| Required "'a basic_type" ("_[1]" [1000] 1000)
| Optional "'a basic_type" ("_[?]" [1000] 1000)
| Collection "'a type"
| Set "'a type"
| OrderedSet "'a type"
| Bag "'a type"
| Sequence "'a type"
| Tuple "telem \<rightharpoonup>\<^sub>f 'a type"

text \<open>
  We define the @{text OclInvalid} type separately, because we
  do not need types like @{text "Set(OclInvalid)"} in the theory.
  The @{text "OclVoid[1]"} type is not equal to @{text OclInvalid}.
  For example, @{text "Set(OclVoid[1])"} could theoretically be
  a valid type of the following expression:\<close>

text \<open>
\<^verbatim>\<open>Set{null}->excluding(null)\<close>\<close>

definition "OclInvalid :: 'a type\<^sub>\<bottom> \<equiv> \<bottom>"

instantiation type :: (type) size
begin

primrec size_type :: "'a type \<Rightarrow> nat" where
  "size_type OclSuper = 0"
| "size_type (Required \<tau>) = 0"
| "size_type (Optional \<tau>) = 0"
| "size_type (Collection \<tau>) = Suc (size_type \<tau>)"
| "size_type (Set \<tau>) = Suc (size_type \<tau>)"
| "size_type (OrderedSet \<tau>) = Suc (size_type \<tau>)"
| "size_type (Bag \<tau>) = Suc (size_type \<tau>)"
| "size_type (Sequence \<tau>) = Suc (size_type \<tau>)"
| "size_type (Tuple \<pi>) = Suc (ffold tcf 0 (fset_of_fmap (fmmap size_type \<pi>)))"

instance ..

end

inductive subtype :: "'a::order type \<Rightarrow> 'a type \<Rightarrow> bool" (infix "\<sqsubset>" 65) where
  "\<tau> \<sqsubset>\<^sub>B \<sigma> \<Longrightarrow> \<tau>[1] \<sqsubset> \<sigma>[1]"
| "\<tau> \<sqsubset>\<^sub>B \<sigma> \<Longrightarrow> \<tau>[?] \<sqsubset> \<sigma>[?]"
| "\<tau>[1] \<sqsubset> \<tau>[?]"
| "OclAny[?] \<sqsubset> OclSuper"

| "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> Collection \<tau> \<sqsubset> Collection \<sigma>"
| "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> Set \<tau> \<sqsubset> Set \<sigma>"
| "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> OrderedSet \<tau> \<sqsubset> OrderedSet \<sigma>"
| "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> Bag \<tau> \<sqsubset> Bag \<sigma>"
| "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> Sequence \<tau> \<sqsubset> Sequence \<sigma>"
| "Set \<tau> \<sqsubset> Collection \<tau>"
| "OrderedSet \<tau> \<sqsubset> Collection \<tau>"
| "Bag \<tau> \<sqsubset> Collection \<tau>"
| "Sequence \<tau> \<sqsubset> Collection \<tau>"
| "Collection OclSuper \<sqsubset> OclSuper"

| "strict_subtuple (\<lambda>\<tau> \<sigma>. \<tau> \<sqsubset> \<sigma> \<or> \<tau> = \<sigma>) \<pi> \<xi> \<Longrightarrow>
   Tuple \<pi> \<sqsubset> Tuple \<xi>"
| "Tuple \<pi> \<sqsubset> OclSuper"

declare subtype.intros [intro!]

inductive_cases subtype_x_OclSuper [elim!]: "\<tau> \<sqsubset> OclSuper"
inductive_cases subtype_x_Required [elim!]: "\<tau> \<sqsubset> \<sigma>[1]"
inductive_cases subtype_x_Optional [elim!]: "\<tau> \<sqsubset> \<sigma>[?]"
inductive_cases subtype_x_Collection [elim!]: "\<tau> \<sqsubset> Collection \<sigma>"
inductive_cases subtype_x_Set [elim!]: "\<tau> \<sqsubset> Set \<sigma>"
inductive_cases subtype_x_OrderedSet [elim!]: "\<tau> \<sqsubset> OrderedSet \<sigma>"
inductive_cases subtype_x_Bag [elim!]: "\<tau> \<sqsubset> Bag \<sigma>"
inductive_cases subtype_x_Sequence [elim!]: "\<tau> \<sqsubset> Sequence \<sigma>"
inductive_cases subtype_x_Tuple [elim!]: "\<tau> \<sqsubset> Tuple \<pi>"

inductive_cases subtype_OclSuper_x [elim!]: "OclSuper \<sqsubset> \<sigma>"
inductive_cases subtype_Collection_x [elim!]: "Collection \<tau> \<sqsubset> \<sigma>"

lemma subtype_asym:
  "\<tau> \<sqsubset> \<sigma> \<Longrightarrow> \<sigma> \<sqsubset> \<tau> \<Longrightarrow> False"
  apply2 (induct rule: subtype.induct)
  using basic_subtype_asym apply auto
  using subtuple_antisym by fastforce

(*** Constructors Bijectivity on Transitive Closures ************************)

section \<open>Constructors Bijectivity on Transitive Closures\<close>

lemma Required_bij_on_trancl [simp]:
  "bij_on_trancl subtype Required"
  by (auto simp add: inj_def)

lemma not_subtype_Optional_Required:
  "subtype\<^sup>+\<^sup>+ \<tau>[?] \<sigma> \<Longrightarrow> \<sigma> = \<rho>[1] \<Longrightarrow> P"
  apply2 (induct arbitrary: \<rho> rule: tranclp_induct) by(auto)

lemma Optional_bij_on_trancl [simp]:
  "bij_on_trancl subtype Optional"
  apply (auto simp add: inj_def)
  using not_subtype_Optional_Required by blast

lemma subtype_tranclp_Collection_x:
  "subtype\<^sup>+\<^sup>+ (Collection \<tau>) \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<sigma> = Collection \<rho> \<Longrightarrow> subtype\<^sup>+\<^sup>+ \<tau> \<rho> \<Longrightarrow> P) \<Longrightarrow>
   (\<sigma> = OclSuper \<Longrightarrow> P) \<Longrightarrow> P"
  apply2 (induct rule: tranclp_induct) apply(auto)
  by (metis subtype_Collection_x subtype_OclSuper_x tranclp.trancl_into_trancl)

lemma Collection_bij_on_trancl [simp]:
  "bij_on_trancl subtype Collection"
  apply (auto simp add: inj_def)
  using subtype_tranclp_Collection_x by auto

lemma Set_bij_on_trancl [simp]:
  "bij_on_trancl subtype Set"
  by (auto simp add: inj_def)

lemma OrderedSet_bij_on_trancl [simp]:
  "bij_on_trancl subtype OrderedSet"
  by (auto simp add: inj_def)

lemma Bag_bij_on_trancl [simp]:
  "bij_on_trancl subtype Bag"
  by (auto simp add: inj_def)

lemma Sequence_bij_on_trancl [simp]:
  "bij_on_trancl subtype Sequence"
  by (auto simp add: inj_def)

lemma Tuple_bij_on_trancl [simp]:
  "bij_on_trancl subtype Tuple"
  by (auto simp add: inj_def)

(*** Partial Order of Types *************************************************)

section \<open>Partial Order of Types\<close>

instantiation type :: (order) order
begin

definition "(<) \<equiv> subtype\<^sup>+\<^sup>+"
definition "(\<le>) \<equiv> subtype\<^sup>*\<^sup>*"

(*** Strict Introduction Rules **********************************************)

subsection \<open>Strict Introduction Rules\<close>

lemma type_less_x_Required_intro [intro]:
  "\<tau> = \<rho>[1] \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < \<sigma>[1]"
  unfolding less_type_def less_basic_type_def
  by simp (rule preserve_tranclp; auto)

lemma type_less_x_Optional_intro [intro]:
  "\<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < \<sigma>[?]"
  "\<tau> = \<rho>[?] \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < \<sigma>[?]"
  unfolding less_type_def less_basic_type_def less_eq_basic_type_def
  apply simp_all
  apply (rule preserve_rtranclp''; auto)
  by (rule preserve_tranclp; auto)

lemma type_less_x_Collection_intro [intro]:
  "\<tau> = Collection \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < Collection \<sigma>"
  "\<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < Collection \<sigma>"
  "\<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < Collection \<sigma>"
  "\<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < Collection \<sigma>"
  "\<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < Collection \<sigma>"
  unfolding less_type_def less_eq_type_def
  apply simp_all
  apply (rule_tac ?f="Collection" in preserve_tranclp; auto)
  apply (rule preserve_rtranclp''; auto)
  apply (rule preserve_rtranclp''; auto)
  apply (rule preserve_rtranclp''; auto)
  by (rule preserve_rtranclp''; auto)

lemma type_less_x_Set_intro [intro]:
  "\<tau> = Set \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < Set \<sigma>"
  unfolding less_type_def
  by simp (rule preserve_tranclp; auto)

lemma type_less_x_OrderedSet_intro [intro]:
  "\<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < OrderedSet \<sigma>"
  unfolding less_type_def
  by simp (rule preserve_tranclp; auto)

lemma type_less_x_Bag_intro [intro]:
  "\<tau> = Bag \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < Bag \<sigma>"
  unfolding less_type_def
  by simp (rule preserve_tranclp; auto)

lemma type_less_x_Sequence_intro [intro]:
  "\<tau> = Sequence \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < Sequence \<sigma>"
  unfolding less_type_def
  by simp (rule preserve_tranclp; auto)

lemma fun_or_eq_refl [intro]:
  "reflp (\<lambda>x y. f x y \<or> x = y)"
  by (simp add: reflpI)

lemma type_less_x_Tuple_intro [intro]:
  assumes "\<tau> = Tuple \<pi>"
      and "strict_subtuple (\<le>) \<pi> \<xi>"
    shows "\<tau> < Tuple \<xi>"
proof -
  have "subtuple (\<lambda>\<tau> \<sigma>. \<tau> \<sqsubset> \<sigma> \<or> \<tau> = \<sigma>)\<^sup>*\<^sup>* \<pi> \<xi>"
    using assms(2) less_eq_type_def by auto
  hence "(subtuple (\<lambda>\<tau> \<sigma>. \<tau> \<sqsubset> \<sigma> \<or> \<tau> = \<sigma>))\<^sup>+\<^sup>+ \<pi> \<xi>"
    by simp (rule subtuple_to_trancl; auto)
  hence "(strict_subtuple (\<lambda>\<tau> \<sigma>. \<tau> \<sqsubset> \<sigma> \<or> \<tau> = \<sigma>))\<^sup>*\<^sup>* \<pi> \<xi>"
    by (simp add: tranclp_into_rtranclp)
  hence "(strict_subtuple (\<lambda>\<tau> \<sigma>. \<tau> \<sqsubset> \<sigma> \<or> \<tau> = \<sigma>))\<^sup>+\<^sup>+ \<pi> \<xi>"
    by (meson assms(2) rtranclpD)
  thus ?thesis
    unfolding less_type_def
    using assms(1) apply simp
    by (rule preserve_tranclp; auto)
qed

lemma type_less_x_OclSuper_intro [intro]:
  "\<tau> \<noteq> OclSuper \<Longrightarrow> \<tau> < OclSuper"
  unfolding less_type_def
proof2 (induct \<tau>)
  case OclSuper thus ?case by auto
next
  case (Required \<tau>)
  have "subtype\<^sup>*\<^sup>* \<tau>[1] OclAny[1]"
    apply (rule_tac ?f="Required" in preserve_rtranclp[of basic_subtype], auto)
    by (metis less_eq_basic_type_def type_less_eq_x_OclAny_intro)
  also have "subtype\<^sup>+\<^sup>+ OclAny[1] OclAny[?]" by auto
  also have "subtype\<^sup>+\<^sup>+ OclAny[?] OclSuper" by auto
  finally show ?case by auto
next
  case (Optional \<tau>)
  have "subtype\<^sup>*\<^sup>* \<tau>[?] OclAny[?]"
    apply (rule_tac ?f="Optional" in preserve_rtranclp[of basic_subtype], auto)
    by (metis less_eq_basic_type_def type_less_eq_x_OclAny_intro)
  also have "subtype\<^sup>+\<^sup>+ OclAny[?] OclSuper" by auto
  finally show ?case by auto
next
  case (Collection \<tau>)
  have "subtype\<^sup>*\<^sup>* (Collection \<tau>) (Collection OclSuper)"
    apply (rule_tac ?f="Collection" in preserve_rtranclp[of subtype], auto)
    using Collection.hyps by force
  also have "subtype\<^sup>+\<^sup>+ (Collection OclSuper) OclSuper" by auto
  finally show ?case by auto
next
  case (Set \<tau>)
  have "subtype\<^sup>+\<^sup>+ (Set \<tau>) (Collection \<tau>)" by auto
  also have "subtype\<^sup>*\<^sup>* (Collection \<tau>) (Collection OclSuper)"
    apply (rule_tac ?f="Collection" in preserve_rtranclp[of subtype], auto)
    using Set.hyps by force
  also have "subtype\<^sup>*\<^sup>* (Collection OclSuper) OclSuper" by auto
  finally show ?case by auto
next
  case (OrderedSet \<tau>)
  have "subtype\<^sup>+\<^sup>+ (OrderedSet \<tau>) (Collection \<tau>)" by auto
  also have "subtype\<^sup>*\<^sup>* (Collection \<tau>) (Collection OclSuper)"
    apply (rule_tac ?f="Collection" in preserve_rtranclp[of subtype], auto)
    using OrderedSet.hyps by force
  also have "subtype\<^sup>*\<^sup>* (Collection OclSuper) OclSuper" by auto
  finally show ?case by auto
next
  case (Bag \<tau>)
  have "subtype\<^sup>+\<^sup>+ (Bag \<tau>) (Collection \<tau>)" by auto
  also have "subtype\<^sup>*\<^sup>* (Collection \<tau>) (Collection OclSuper)"
    apply (rule_tac ?f="Collection" in preserve_rtranclp[of subtype], auto)
    using Bag.hyps by force
  also have "subtype\<^sup>*\<^sup>* (Collection OclSuper) OclSuper" by auto
  finally show ?case by auto
next
  case (Sequence \<tau>)
  have "subtype\<^sup>+\<^sup>+ (Sequence \<tau>) (Collection \<tau>)" by auto
  also have "subtype\<^sup>*\<^sup>* (Collection \<tau>) (Collection OclSuper)"
    apply (rule_tac ?f="Collection" in preserve_rtranclp[of subtype], auto)
    using Sequence.hyps by force
  also have "subtype\<^sup>*\<^sup>* (Collection OclSuper) OclSuper" by auto
  finally show ?case by auto
next
  case (Tuple x) thus ?case by auto
qed

(*** Strict Elimination Rules ***********************************************)

subsection \<open>Strict Elimination Rules\<close>

lemma type_less_x_Required [elim!]:
  assumes "\<tau> < \<sigma>[1]"
      and "\<And>\<rho>. \<tau> = \<rho>[1] \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<rho> where "\<tau> = \<rho>[1]"
    unfolding less_type_def
    apply2 (induct rule: converse_tranclp_induct) by (auto)
  moreover have "\<And>\<tau> \<sigma>. \<tau>[1] < \<sigma>[1] \<Longrightarrow> \<tau> < \<sigma>"
    unfolding less_type_def less_basic_type_def
    by (rule reflect_tranclp; auto)
  ultimately show ?thesis
    using assms by auto
qed

(*
lemma type_less_x_Optional [elim!]:
  assumes "\<tau> < \<sigma>[?]"
      and "\<tau> = OclVoid \<Longrightarrow> P"
      and "\<And>\<rho>. \<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P"
      and "\<And>\<rho>. \<tau> = \<rho>[?] \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<rho> where
    "\<tau> = OclVoid \<or> \<tau> = \<rho>[1] \<or> \<tau> = \<rho>[?]"
    unfolding less_type_def
    by (induct rule: converse_tranclp_induct; auto)
  moreover have "\<And>\<tau> \<sigma>. \<tau>[1] < \<sigma>[?] \<Longrightarrow> \<tau> \<le> \<sigma>"
    unfolding less_type_def less_eq_basic_type_def
    apply (drule tranclpD, auto)
    apply (erule subtype.cases, auto)
  moreover have "\<And>\<tau> \<sigma>. \<tau>[?] < \<sigma>[?] \<Longrightarrow> \<tau> < \<sigma>"
    unfolding less_type_def less_basic_type_def
    by (rule reflect_tranclp; auto)
  ultimately show ?thesis
    using assms by auto
qed
*)
lemma type_less_x_Optional [elim!]:
  "\<tau> < \<sigma>[?] \<Longrightarrow>
   (\<And>\<rho>. \<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = \<rho>[?] \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_type_def
  apply2 (induct rule: converse_tranclp_induct)
  apply (metis subtype_x_Optional eq_refl less_basic_type_def tranclp.r_into_trancl)
  apply (erule subtype.cases; auto)
  apply (simp add: converse_rtranclp_into_rtranclp less_eq_basic_type_def)
  by (simp add: less_basic_type_def tranclp_into_tranclp2)

lemma type_less_x_Collection [elim!]:
  "\<tau> < Collection \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Collection \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_type_def
  apply2 (induct rule: converse_tranclp_induct)
  apply (metis (mono_tags) Nitpick.rtranclp_unfold
          subtype_x_Collection less_eq_type_def tranclp.r_into_trancl)
  by (erule subtype.cases;
      auto simp add: converse_rtranclp_into_rtranclp less_eq_type_def
                     tranclp_into_tranclp2 tranclp_into_rtranclp)

lemma type_less_x_Set [elim!]:
  assumes "\<tau> < Set \<sigma>"
      and "\<And>\<rho>. \<tau> = Set \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<rho> where "\<tau> = Set \<rho>"
    unfolding less_type_def
    apply2 (induct rule: converse_tranclp_induct) by (auto)
  moreover have "\<And>\<tau> \<sigma>. Set \<tau> < Set \<sigma> \<Longrightarrow> \<tau> < \<sigma>"
    unfolding less_type_def
    by (rule reflect_tranclp; auto)
  ultimately show ?thesis
    using assms by auto
qed

lemma type_less_x_Bag [elim!]:
  assumes "\<tau> < Bag \<sigma>"
      and "\<And>\<rho>. \<tau> = Bag \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<rho> where "\<tau> = Bag \<rho>"
    unfolding less_type_def
    apply2 (induct rule: converse_tranclp_induct) by (auto)
  moreover have "\<And>\<tau> \<sigma>. Bag \<tau> < Bag \<sigma> \<Longrightarrow> \<tau> < \<sigma>"
    unfolding less_type_def
    by (rule reflect_tranclp; auto)
  ultimately show ?thesis
    using assms by auto
qed

lemma type_less_x_Sequence [elim!]:
  assumes "\<tau> < Sequence \<sigma>"
      and "\<And>\<rho>. \<tau> = Sequence \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<rho> where "\<tau> = Sequence \<rho>"
    unfolding less_type_def
    apply2 (induct rule: converse_tranclp_induct) by (auto)
  moreover have "\<And>\<tau> \<sigma>. Sequence \<tau> < Sequence \<sigma> \<Longrightarrow> \<tau> < \<sigma>"
    unfolding less_type_def
    by (rule reflect_tranclp; auto)
  ultimately show ?thesis
    using assms by auto
qed

text \<open>
  We will be able to remove the acyclicity assumption only after
  we prove that the subtype relation is acyclic.\<close>

lemma type_less_x_Tuple':
  assumes "\<tau> < Tuple \<xi>"
      and "acyclicP_on (fmran' \<xi>) subtype"
      and "\<And>\<pi>. \<tau> = Tuple \<pi> \<Longrightarrow> strict_subtuple (\<le>) \<pi> \<xi> \<Longrightarrow> P"
    shows "P"
proof -
  from assms(1) obtain \<pi> where "\<tau> = Tuple \<pi>"
    unfolding less_type_def
    apply2 (induct rule: converse_tranclp_induct) by (auto)
  moreover from assms(2) have
    "\<And>\<pi>. Tuple \<pi> < Tuple \<xi> \<Longrightarrow> strict_subtuple (\<le>) \<pi> \<xi>"
    unfolding less_type_def less_eq_type_def
    by (rule_tac ?f="Tuple" in strict_subtuple_rtranclp_intro; auto)
  ultimately show ?thesis
    using assms by auto
qed

lemma type_less_x_OclSuper [elim!]:
  "\<tau> < OclSuper \<Longrightarrow> (\<tau> \<noteq> OclSuper \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding less_type_def
  by (drule tranclpD, auto)

(*** Properties *************************************************************)

subsection \<open>Properties\<close>

lemma subtype_irrefl:
  "\<tau> < \<tau> \<Longrightarrow> False"
  for \<tau> :: "'a type"
  apply2 (induct \<tau>) apply (auto)
  apply (erule type_less_x_Tuple', auto)
  unfolding less_type_def tranclp_unfold
  by auto

lemma subtype_acyclic:
  "acyclicP subtype"
  apply (rule acyclicI)
  apply (simp add: trancl_def)
  by (metis (mono_tags) OCL_Types.less_type_def OCL_Types.subtype_irrefl)

lemma less_le_not_le_type:
  "\<tau> < \<sigma> \<longleftrightarrow> \<tau> \<le> \<sigma> \<and> \<not> \<sigma> \<le> \<tau>"
  for \<tau> \<sigma> :: "'a type"
proof
  show "\<tau> < \<sigma> \<Longrightarrow> \<tau> \<le> \<sigma> \<and> \<not> \<sigma> \<le> \<tau>"
    apply (auto simp add: less_type_def less_eq_type_def)
    by (metis (mono_tags) subtype_irrefl less_type_def tranclp_rtranclp_tranclp)
  show "\<tau> \<le> \<sigma> \<and> \<not> \<sigma> \<le> \<tau> \<Longrightarrow> \<tau> < \<sigma>"
    apply (auto simp add: less_type_def less_eq_type_def)
    by (metis rtranclpD)
qed

lemma order_refl_type [iff]:
  "\<tau> \<le> \<tau>"
  for \<tau> :: "'a type"
  unfolding less_eq_type_def by simp

lemma order_trans_type:
  "\<tau> \<le> \<sigma> \<Longrightarrow> \<sigma> \<le> \<rho> \<Longrightarrow> \<tau> \<le> \<rho>"
  for \<tau> \<sigma> \<rho> :: "'a type"
  unfolding less_eq_type_def by simp

lemma antisym_type:
  "\<tau> \<le> \<sigma> \<Longrightarrow> \<sigma> \<le> \<tau> \<Longrightarrow> \<tau> = \<sigma>"
  for \<tau> \<sigma> :: "'a type"
  unfolding less_eq_type_def less_type_def
  by (metis (mono_tags, lifting) less_eq_type_def
      less_le_not_le_type less_type_def rtranclpD)

instance
  apply intro_classes
  apply (simp add: less_le_not_le_type)
  apply (simp)
  using order_trans_type apply blast
  by (simp add: antisym_type)

end

(*** Non-Strict Introduction Rules ******************************************)

subsection \<open>Non-Strict Introduction Rules\<close>

lemma type_less_eq_x_Required_intro [intro]:
  "\<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> \<sigma>[1]"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Optional_intro [intro]:
  "\<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> \<sigma>[?]"
  "\<tau> = \<rho>[?] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> \<sigma>[?]"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Collection_intro [intro]:
  "\<tau> = Collection \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Collection \<sigma>"
  "\<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Collection \<sigma>"
  "\<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Collection \<sigma>"
  "\<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Collection \<sigma>"
  "\<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Collection \<sigma>"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Set_intro [intro]:
  "\<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Set \<sigma>"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_OrderedSet_intro [intro]:
  "\<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> OrderedSet \<sigma>"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Bag_intro [intro]:
  "\<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Bag \<sigma>"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Sequence_intro [intro]:
  "\<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Sequence \<sigma>"
  unfolding dual_order.order_iff_strict by auto

lemma type_less_eq_x_Tuple_intro [intro]:
  "\<tau> = Tuple \<pi> \<Longrightarrow> subtuple (\<le>) \<pi> \<xi> \<Longrightarrow> \<tau> \<le> Tuple \<xi>"
  using dual_order.strict_iff_order by blast

lemma type_less_eq_x_OclSuper_intro [intro]:
  "\<tau> \<le> OclSuper"
  unfolding dual_order.order_iff_strict by auto

(*** Non-Strict Elimination Rules *******************************************)

subsection \<open>Non-Strict Elimination Rules\<close>

lemma type_less_eq_x_Required [elim!]:
  "\<tau> \<le> \<sigma>[1] \<Longrightarrow>
   (\<And>\<rho>. \<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Optional [elim!]:
  "\<tau> \<le> \<sigma>[?] \<Longrightarrow>
   (\<And>\<rho>. \<tau> = \<rho>[1] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = \<rho>[?] \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq, auto)

lemma type_less_eq_x_Collection [elim!]:
  "\<tau> \<le> Collection \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Collection \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Set [elim!]:
   "\<tau> \<le> Set \<sigma> \<Longrightarrow>
    (\<And>\<rho>. \<tau> = Set \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_OrderedSet [elim!]:
   "\<tau> \<le> OrderedSet \<sigma> \<Longrightarrow>
    (\<And>\<rho>. \<tau> = OrderedSet \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Bag [elim!]:
   "\<tau> \<le> Bag \<sigma> \<Longrightarrow>
    (\<And>\<rho>. \<tau> = Bag \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_eq_x_Sequence [elim!]:
   "\<tau> \<le> Sequence \<sigma> \<Longrightarrow>
    (\<And>\<rho>. \<tau> = Sequence \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (drule le_imp_less_or_eq; auto)

lemma type_less_x_Tuple [elim!]:
  "\<tau> < Tuple \<xi> \<Longrightarrow>
   (\<And>\<pi>. \<tau> = Tuple \<pi> \<Longrightarrow> strict_subtuple (\<le>) \<pi> \<xi> \<Longrightarrow> P) \<Longrightarrow> P"
  apply (erule type_less_x_Tuple')
  by (meson acyclic_def subtype_acyclic)

lemma type_less_eq_x_Tuple [elim!]:
  "\<tau> \<le> Tuple \<xi> \<Longrightarrow>
   (\<And>\<pi>. \<tau> = Tuple \<pi> \<Longrightarrow> subtuple (\<le>) \<pi> \<xi> \<Longrightarrow> P) \<Longrightarrow> P"
  apply (drule le_imp_less_or_eq, auto)
  by (simp add: fmap.rel_refl fmrel_to_subtuple)

(*** Simplification Rules ***************************************************)

subsection \<open>Simplification Rules\<close>

lemma type_less_left_simps [simp]:
  "OclSuper < \<sigma> = False"
  "\<rho>[1] < \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = OclSuper \<or>
      \<sigma> = \<upsilon>[1] \<and> \<rho> < \<upsilon> \<or>
      \<sigma> = \<upsilon>[?] \<and> \<rho> \<le> \<upsilon>)"
  "\<rho>[?] < \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = OclSuper \<or>
      \<sigma> = \<upsilon>[?] \<and> \<rho> < \<upsilon>)"
  "Collection \<tau> < \<sigma> = (\<exists>\<phi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Collection \<phi> \<and> \<tau> < \<phi>)"
  "Set \<tau> < \<sigma> = (\<exists>\<phi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Collection \<phi> \<and> \<tau> \<le> \<phi> \<or>
      \<sigma> = Set \<phi> \<and> \<tau> < \<phi>)"
  "OrderedSet \<tau> < \<sigma> = (\<exists>\<phi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Collection \<phi> \<and> \<tau> \<le> \<phi> \<or>
      \<sigma> = OrderedSet \<phi> \<and> \<tau> < \<phi>)"
  "Bag \<tau> < \<sigma> = (\<exists>\<phi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Collection \<phi> \<and> \<tau> \<le> \<phi> \<or>
      \<sigma> = Bag \<phi> \<and> \<tau> < \<phi>)"
  "Sequence \<tau> < \<sigma> = (\<exists>\<phi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Collection \<phi> \<and> \<tau> \<le> \<phi> \<or>
      \<sigma> = Sequence \<phi> \<and> \<tau> < \<phi>)"
  "Tuple \<pi> < \<sigma> = (\<exists>\<xi>.
      \<sigma> = OclSuper \<or>
      \<sigma> = Tuple \<xi> \<and> strict_subtuple (\<le>) \<pi> \<xi>)"
(*apply (induct \<sigma>; auto)+*)
          apply -
          apply2(induct \<sigma>)apply auto[9]
         apply2(induct \<sigma>)apply auto[9]
        apply2(induct \<sigma>)apply auto[9]
       apply2(induct \<sigma>)apply auto[9]
  apply2(induct \<sigma>)apply auto[9]
  apply2(induct \<sigma>)apply auto[9]
  apply2(induct \<sigma>)apply auto[9]
  apply2(induct \<sigma>)apply auto[9]
  apply2(induct \<sigma>)apply auto[9]
  done

lemma type_less_right_simps [simp]:
  "\<tau> < OclSuper = (\<tau> \<noteq> OclSuper)"
  "\<tau> < \<upsilon>[1] = (\<exists>\<rho>. \<tau> = \<rho>[1] \<and> \<rho> < \<upsilon>)"
  "\<tau> < \<upsilon>[?] = (\<exists>\<rho>. \<tau> = \<rho>[1] \<and> \<rho> \<le> \<upsilon> \<or> \<tau> = \<rho>[?] \<and> \<rho> < \<upsilon>)"
  "\<tau> < Collection \<sigma> = (\<exists>\<phi>.
      \<tau> = Collection \<phi> \<and> \<phi> < \<sigma> \<or>
      \<tau> = Set \<phi> \<and> \<phi> \<le> \<sigma> \<or>
      \<tau> = OrderedSet \<phi> \<and> \<phi> \<le> \<sigma> \<or>
      \<tau> = Bag \<phi> \<and> \<phi> \<le> \<sigma> \<or>
      \<tau> = Sequence \<phi> \<and> \<phi> \<le> \<sigma>)"
  "\<tau> < Set \<sigma> = (\<exists>\<phi>. \<tau> = Set \<phi> \<and> \<phi> < \<sigma>)"
  "\<tau> < OrderedSet \<sigma> = (\<exists>\<phi>. \<tau> = OrderedSet \<phi> \<and> \<phi> < \<sigma>)"
  "\<tau> < Bag \<sigma> = (\<exists>\<phi>. \<tau> = Bag \<phi> \<and> \<phi> < \<sigma>)"
  "\<tau> < Sequence \<sigma> = (\<exists>\<phi>. \<tau> = Sequence \<phi> \<and> \<phi> < \<sigma>)"
  "\<tau> < Tuple \<xi> = (\<exists>\<pi>. \<tau> = Tuple \<pi> \<and> strict_subtuple (\<le>) \<pi> \<xi>)"
  by auto

(*** Upper Semilattice of Types *********************************************)

section \<open>Upper Semilattice of Types\<close>

instantiation type :: (semilattice_sup) semilattice_sup
begin

fun sup_type where
  "OclSuper \<squnion> \<sigma> = OclSuper"
| "Required \<tau> \<squnion> \<sigma> = (case \<sigma>
    of \<rho>[1] \<Rightarrow> (\<tau> \<squnion> \<rho>)[1]
     | \<rho>[?] \<Rightarrow> (\<tau> \<squnion> \<rho>)[?]
     | _ \<Rightarrow> OclSuper)"
| "Optional \<tau> \<squnion> \<sigma> = (case \<sigma>
    of \<rho>[1] \<Rightarrow> (\<tau> \<squnion> \<rho>)[?]
     | \<rho>[?] \<Rightarrow> (\<tau> \<squnion> \<rho>)[?]
     | _ \<Rightarrow> OclSuper)"
| "Collection \<tau> \<squnion> \<sigma> = (case \<sigma>
    of Collection \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Set \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | OrderedSet \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Bag \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Sequence \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | _ \<Rightarrow> OclSuper)"
| "Set \<tau> \<squnion> \<sigma> = (case \<sigma>
    of Collection \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Set \<rho> \<Rightarrow> Set (\<tau> \<squnion> \<rho>)
     | OrderedSet \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Bag \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Sequence \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | _ \<Rightarrow> OclSuper)"
| "OrderedSet \<tau> \<squnion> \<sigma> = (case \<sigma>
    of Collection \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Set \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | OrderedSet \<rho> \<Rightarrow> OrderedSet (\<tau> \<squnion> \<rho>)
     | Bag \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Sequence \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | _ \<Rightarrow> OclSuper)"
| "Bag \<tau> \<squnion> \<sigma> = (case \<sigma>
    of Collection \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Set \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | OrderedSet \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Bag \<rho> \<Rightarrow> Bag (\<tau> \<squnion> \<rho>)
     | Sequence \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | _ \<Rightarrow> OclSuper)"
| "Sequence \<tau> \<squnion> \<sigma> = (case \<sigma>
    of Collection \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Set \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | OrderedSet \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Bag \<rho> \<Rightarrow> Collection (\<tau> \<squnion> \<rho>)
     | Sequence \<rho> \<Rightarrow> Sequence (\<tau> \<squnion> \<rho>)
     | _ \<Rightarrow> OclSuper)"
| "Tuple \<pi> \<squnion> \<sigma> = (case \<sigma>
    of Tuple \<xi> \<Rightarrow> Tuple (fmmerge_fun (\<squnion>) \<pi> \<xi>)
     | _ \<Rightarrow> OclSuper)"

lemma sup_ge1_type:
  "\<tau> \<le> \<tau> \<squnion> \<sigma>"
  for \<tau> \<sigma> :: "'a type"
proof2 (induct \<tau> arbitrary: \<sigma>)
  case OclSuper show ?case by simp
  case (Required \<tau>) show ?case apply2 (induct \<sigma>) by (auto)
  case (Optional \<tau>) show ?case apply2 (induct \<sigma>) by (auto)
  case (Collection \<tau>) thus ?case apply2 (induct \<sigma>) by (auto)
  case (Set \<tau>) thus ?case apply2 (induct \<sigma>) by (auto)
  case (OrderedSet \<tau>) thus ?case apply2 (induct \<sigma>) by (auto)
  case (Bag \<tau>) thus ?case apply2 (induct \<sigma>) by (auto)
  case (Sequence \<tau>) thus ?case apply2 (induct \<sigma>) by(auto)
next
  case (Tuple \<pi>)
  moreover have Tuple_less_eq_sup:
    "(\<And>\<tau> \<sigma>. \<tau> \<in> fmran' \<pi> \<Longrightarrow> \<tau> \<le> \<tau> \<squnion> \<sigma>) \<Longrightarrow>
     Tuple \<pi> \<le> Tuple \<pi> \<squnion> \<sigma>"
    by (cases \<sigma>, auto)
  ultimately show ?case by (cases \<sigma>, auto)
qed

lemma sup_commut_type:
  "\<tau> \<squnion> \<sigma> = \<sigma> \<squnion> \<tau>"
  for \<tau> \<sigma> :: "'a type"
proof2 (induct \<tau> arbitrary: \<sigma>)
  case OclSuper show ?case by (cases \<sigma>; simp add: less_eq_type_def)
  case (Required \<tau>) show ?case by (cases \<sigma>; simp add: sup_commute)
  case (Optional \<tau>) show ?case by (cases \<sigma>; simp add: sup_commute)
  case (Collection \<tau>) thus ?case by (cases \<sigma>; simp)
  case (Set \<tau>) thus ?case by (cases \<sigma>; simp)
  case (OrderedSet \<tau>) thus ?case by (cases \<sigma>; simp)
  case (Bag \<tau>) thus ?case by (cases \<sigma>; simp)
  case (Sequence \<tau>) thus ?case by (cases \<sigma>; simp)
next
  case (Tuple \<pi>) thus ?case
    apply (cases \<sigma>; simp add: less_eq_type_def)
    using fmmerge_commut by blast
qed

lemma sup_least_type:
  "\<tau> \<le> \<rho> \<Longrightarrow> \<sigma> \<le> \<rho> \<Longrightarrow> \<tau> \<squnion> \<sigma> \<le> \<rho>"
  for \<tau> \<sigma> \<rho> :: "'a type"
proof2 (induct \<rho> arbitrary: \<tau> \<sigma>)
  case OclSuper show ?case using eq_refl by auto
next
  case (Required x) show ?case
    apply (insert Required)
    by (erule type_less_eq_x_Required; erule type_less_eq_x_Required; auto)
next
  case (Optional x) show ?case
    apply (insert Optional)
    by (erule type_less_eq_x_Optional; erule type_less_eq_x_Optional; auto)
next
  case (Collection \<rho>) show ?case
    apply (insert Collection)
    by (erule type_less_eq_x_Collection; erule type_less_eq_x_Collection; auto)
next
  case (Set \<rho>) show ?case
    apply (insert Set)
    by (erule type_less_eq_x_Set; erule type_less_eq_x_Set; auto)
next
  case (OrderedSet \<rho>) show ?case
    apply (insert OrderedSet)
    by (erule type_less_eq_x_OrderedSet; erule type_less_eq_x_OrderedSet; auto)
next
  case (Bag \<rho>) show ?case
    apply (insert Bag)
    by (erule type_less_eq_x_Bag; erule type_less_eq_x_Bag; auto)
next
  case (Sequence \<rho>) thus ?case
    apply (insert Sequence)
    by (erule type_less_eq_x_Sequence; erule type_less_eq_x_Sequence; auto)
next
  case (Tuple \<pi>) show ?case
    apply (insert Tuple)
    apply (erule type_less_eq_x_Tuple; erule type_less_eq_x_Tuple; auto)
    by (rule_tac ?\<pi>="(fmmerge (\<squnion>) \<pi>' \<pi>'')" in type_less_eq_x_Tuple_intro;
        simp add: fmrel_on_fset_fmmerge1)
qed

instance
  apply intro_classes
  apply (simp add: sup_ge1_type)
  apply (simp add: sup_commut_type sup_ge1_type)
  by (simp add: sup_least_type)

end

(*** Helper Relations *******************************************************)

section \<open>Helper Relations\<close>

abbreviation between ("_/ = _\<midarrow>_"  [51, 51, 51] 50) where
  "x = y\<midarrow>z \<equiv> y \<le> x \<and> x \<le> z"

inductive element_type where
  "element_type (Collection \<tau>) \<tau>"
| "element_type (Set \<tau>) \<tau>"
| "element_type (OrderedSet \<tau>) \<tau>"
| "element_type (Bag \<tau>) \<tau>"
| "element_type (Sequence \<tau>) \<tau>"

lemma element_type_alt_simps:
  "element_type \<tau> \<sigma> =
     (Collection \<sigma> = \<tau> \<or>
      Set \<sigma> = \<tau> \<or>
      OrderedSet \<sigma> = \<tau> \<or>
      Bag \<sigma> = \<tau> \<or>
      Sequence \<sigma> = \<tau>)"
  by (auto simp add: element_type.simps)

inductive update_element_type where
  "update_element_type (Collection _) \<tau> (Collection \<tau>)"
| "update_element_type (Set _) \<tau> (Set \<tau>)"
| "update_element_type (OrderedSet _) \<tau> (OrderedSet \<tau>)"
| "update_element_type (Bag _) \<tau> (Bag \<tau>)"
| "update_element_type (Sequence _) \<tau> (Sequence \<tau>)"

inductive to_unique_collection where
  "to_unique_collection (Collection \<tau>) (Set \<tau>)"
| "to_unique_collection (Set \<tau>) (Set \<tau>)"
| "to_unique_collection (OrderedSet \<tau>) (OrderedSet \<tau>)"
| "to_unique_collection (Bag \<tau>) (Set \<tau>)"
| "to_unique_collection (Sequence \<tau>) (OrderedSet \<tau>)"

inductive to_nonunique_collection where
  "to_nonunique_collection (Collection \<tau>) (Bag \<tau>)"
| "to_nonunique_collection (Set \<tau>) (Bag \<tau>)"
| "to_nonunique_collection (OrderedSet \<tau>) (Sequence \<tau>)"
| "to_nonunique_collection (Bag \<tau>) (Bag \<tau>)"
| "to_nonunique_collection (Sequence \<tau>) (Sequence \<tau>)"

inductive to_ordered_collection where
  "to_ordered_collection (Collection \<tau>) (Sequence \<tau>)"
| "to_ordered_collection (Set \<tau>) (OrderedSet \<tau>)"
| "to_ordered_collection (OrderedSet \<tau>) (OrderedSet \<tau>)"
| "to_ordered_collection (Bag \<tau>) (Sequence \<tau>)"
| "to_ordered_collection (Sequence \<tau>) (Sequence \<tau>)"

fun to_single_type where
  "to_single_type OclSuper = OclSuper"
| "to_single_type \<tau>[1] = \<tau>[1]"
| "to_single_type \<tau>[?] = \<tau>[?]"
| "to_single_type (Collection \<tau>) = to_single_type \<tau>"
| "to_single_type (Set \<tau>) = to_single_type \<tau>"
| "to_single_type (OrderedSet \<tau>) = to_single_type \<tau>"
| "to_single_type (Bag \<tau>) = to_single_type \<tau>"
| "to_single_type (Sequence \<tau>) = to_single_type \<tau>"
| "to_single_type (Tuple \<pi>) = Tuple \<pi>"

fun to_required_type where
  "to_required_type \<tau>[1] = \<tau>[1]"
| "to_required_type \<tau>[?] = \<tau>[1]"
| "to_required_type \<tau> = \<tau>"

fun to_optional_type_nested where
  "to_optional_type_nested OclSuper = OclSuper"
| "to_optional_type_nested \<tau>[1] = \<tau>[?]"
| "to_optional_type_nested \<tau>[?] = \<tau>[?]"
| "to_optional_type_nested (Collection \<tau>) = Collection (to_optional_type_nested \<tau>)"
| "to_optional_type_nested (Set \<tau>) = Set (to_optional_type_nested \<tau>)"
| "to_optional_type_nested (OrderedSet \<tau>) = OrderedSet (to_optional_type_nested \<tau>)"
| "to_optional_type_nested (Bag \<tau>) = Bag (to_optional_type_nested \<tau>)"
| "to_optional_type_nested (Sequence \<tau>) = Sequence (to_optional_type_nested \<tau>)"
| "to_optional_type_nested (Tuple \<pi>) = Tuple (fmmap to_optional_type_nested \<pi>)"

(*** Determinism ************************************************************)

section \<open>Determinism\<close>

lemma element_type_det:
  "element_type \<tau> \<sigma>\<^sub>1 \<Longrightarrow>
   element_type \<tau> \<sigma>\<^sub>2 \<Longrightarrow> \<sigma>\<^sub>1 = \<sigma>\<^sub>2"
  apply2 (induct rule: element_type.induct) apply(simp add: element_type.simps)+ done

lemma to_unique_collection_det:
  "to_unique_collection \<tau> \<sigma>\<^sub>1 \<Longrightarrow>
   to_unique_collection \<tau> \<sigma>\<^sub>2 \<Longrightarrow> \<sigma>\<^sub>1 = \<sigma>\<^sub>2"
  apply2 (induct rule: to_unique_collection.induct) apply(simp add: to_unique_collection.simps)+ done

lemma to_nonunique_collection_det:
  "to_nonunique_collection \<tau> \<sigma>\<^sub>1 \<Longrightarrow>
   to_nonunique_collection \<tau> \<sigma>\<^sub>2 \<Longrightarrow> \<sigma>\<^sub>1 = \<sigma>\<^sub>2"
  apply2 (induct rule: to_nonunique_collection.induct) apply(simp add: to_nonunique_collection.simps)+ done

lemma to_ordered_collection_det:
  "to_ordered_collection \<tau> \<sigma>\<^sub>1 \<Longrightarrow>
   to_ordered_collection \<tau> \<sigma>\<^sub>2 \<Longrightarrow> \<sigma>\<^sub>1 = \<sigma>\<^sub>2"
  apply2 (induct rule: to_ordered_collection.induct) apply(simp add: to_ordered_collection.simps)+ done

(*** Code Setup *************************************************************)

section \<open>Code Setup\<close>

code_pred subtype .

function subtype_fun :: "'a::order type \<Rightarrow> 'a type \<Rightarrow> bool" where
  "subtype_fun OclSuper _ = False"
| "subtype_fun (Required \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | \<rho>[1] \<Rightarrow> basic_subtype_fun \<tau> \<rho>
     | \<rho>[?] \<Rightarrow> basic_subtype_fun \<tau> \<rho> \<or> \<tau> = \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Optional \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | \<rho>[?] \<Rightarrow> basic_subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Collection \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Collection \<rho> \<Rightarrow> subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Set \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Collection \<rho> \<Rightarrow> subtype_fun \<tau> \<rho> \<or> \<tau> = \<rho>
     | Set \<rho> \<Rightarrow> subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (OrderedSet \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Collection \<rho> \<Rightarrow> subtype_fun \<tau> \<rho> \<or> \<tau> = \<rho>
     | OrderedSet \<rho> \<Rightarrow> subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Bag \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Collection \<rho> \<Rightarrow> subtype_fun \<tau> \<rho> \<or> \<tau> = \<rho>
     | Bag \<rho> \<Rightarrow> subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Sequence \<tau>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Collection \<rho> \<Rightarrow> subtype_fun \<tau> \<rho> \<or> \<tau> = \<rho>
     | Sequence \<rho> \<Rightarrow> subtype_fun \<tau> \<rho>
     | _ \<Rightarrow> False)"
| "subtype_fun (Tuple \<pi>) \<sigma> = (case \<sigma>
    of OclSuper \<Rightarrow> True
     | Tuple \<xi> \<Rightarrow> strict_subtuple_fun (\<lambda>\<tau> \<sigma>. subtype_fun \<tau> \<sigma> \<or> \<tau> = \<sigma>) \<pi> \<xi>
     | _ \<Rightarrow> False)"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(xs, ys). size ys)";
      auto simp add: elem_le_ffold' fmran'I)

lemma less_eq_type_code [code]:
  "(\<le>) = (\<lambda>x y. subtype_fun x y \<or> x = y)"
  unfolding dual_order.order_iff_strict less_type_code
  by auto

code_pred element_type .
code_pred update_element_type .
code_pred to_unique_collection .
code_pred to_nonunique_collection .
code_pred to_ordered_collection .

end


theory SINVAR_CommunicationPartners
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant CommunicationPartners *}

text{*
Idea of this securityinvariant:
  Only some nodes can communicate with Master nodes.
    It constraints who may access master nodes, Master nodes can access the world (except other prohibited master nodes).
  A node configured as Master has a list of nodes that can access it.
  Also, in order to be able to access a Master node, the sender must be denoted as a node we Care about.
  By default, all nodes are set to DonTCare, thus they can not access Master nodes. But they can access
  all other DontCare nodes and Care nodes.

  TL;DR: An access control list determines who can access a master node.
*}
datatype 'v node_config = DontCare | Care | Master "'v list"

definition default_node_properties :: "'v node_config"
  where  "default_node_properties = DontCare"

text{* Unrestricted accesses among DontCare nodes! *}

fun allowed_flow :: "'v node_config \<Rightarrow> 'v \<Rightarrow> 'v node_config \<Rightarrow> 'v \<Rightarrow> bool" where
  "allowed_flow DontCare s DontCare r = True" |
  "allowed_flow DontCare s Care r = True" |
  "allowed_flow DontCare s (Master _) r = False" |
  "allowed_flow Care s Care r = True" |
  "allowed_flow Care s DontCare r = True" |
  "allowed_flow Care s (Master M) r = (s \<in> set M)" |
  "allowed_flow (Master _) s (Master M) r = (s \<in> set M)" |
  "allowed_flow (Master _) s Care r = True" |
  "allowed_flow (Master _) s DontCare r = True"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s,r) \<in> edges G. s \<noteq> r \<longrightarrow> allowed_flow (nP s) s (nP r) r)"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v node_config) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

subsubsection {*ENRnr*}
  lemma CommunicationPartners_ENRnrSR: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_SR sinvar allowed_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_SR_def)
  lemma Unassigned_weakrefl: "\<forall> s r. allowed_flow DontCare s DontCare r"
    by(simp)
  lemma Unassigned_botdefault: "\<forall> s r. (nP r) \<noteq> DontCare \<longrightarrow> \<not> allowed_flow (nP s) s (nP r) r \<longrightarrow> \<not> allowed_flow DontCare s (nP r) r"
    apply(rule allI)+
    apply(case_tac "nP r")
      apply(simp_all)
    apply(case_tac "nP s")
      apply(simp_all)
    done
  lemma  "\<not> allowed_flow DontCare s (Master M) r" by(simp)

  lemma All_to_Unassigned: "\<forall> s r. allowed_flow (nP s) s DontCare r"
    by (rule allI, rule allI, case_tac "nP s", simp_all)
  lemma Unassigned_default_candidate: "\<forall> s r. \<not> allowed_flow (nP s) s (nP r) r \<longrightarrow> \<not> allowed_flow DontCare s (nP r) r"
    apply(rule allI)+
    apply(case_tac "nP s")
      apply(simp_all)
     apply(case_tac "nP r")
       apply(simp_all)
    apply(case_tac "nP r")
      apply(simp_all)
    done

  definition CommunicationPartners_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "CommunicationPartners_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_flow (nP e1) e1 (nP e2) e2} })"
  lemma CommunicationPartners_offending_set:
  "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = CommunicationPartners_offending_set"
    apply(simp only: fun_eq_iff ENFnrSR_offending_set[OF CommunicationPartners_ENRnrSR] CommunicationPartners_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation CommunicationPartners: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = CommunicationPartners_offending_set"
  unfolding receiver_violation_def
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule_tac f="f" in SecurityInvariant_withOffendingFlows.ENFnrSR_fsts_weakrefl_instance[OF CommunicationPartners_ENRnrSR Unassigned_weakrefl Unassigned_botdefault All_to_Unassigned])
     apply(simp)
    apply(simp)
  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(simp add: CommunicationPartners_offending_set CommunicationPartners_offending_set_def delete_edges_simp2)
  apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. DontCare)(vertex_1 := DontCare, vertex_2 := Master [vertex_1])" in exI, simp)
   apply(rule_tac x="vertex_1" in exI, simp)
   apply(simp split: split_split)
   apply(clarify)
   apply force
  apply(rename_tac M) (*case Master M*)
  apply(rule_tac x="(\<lambda> x. DontCare)(vertex_1 := DontCare, vertex_2 := (Master (vertex_1#M')))" in exI, simp)
  apply(simp split: split_split)
  apply(clarify)
  apply force
 apply(fact CommunicationPartners_offending_set)
done

  lemma TopoS_SubnetsInGW: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


theory sf_DDL imports Main            (*Xavier Parent*)

begin (* DDL: Dyadic Deontic Logic with selection functions *)
 typedecl i (*type for possible worlds*)
 type_synonym \<tau> = "(i\<Rightarrow>bool)"
 type_synonym \<gamma> = "\<tau>\<Rightarrow>\<tau>"
 type_synonym \<rho> = "\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>"

 consts av::"i\<Rightarrow>\<tau>" pv::"i\<Rightarrow>\<tau>" ob::"\<tau>\<Rightarrow>(\<tau>\<Rightarrow>bool)" (*accessibility relations*)
            cw::i (*current world*)

 axiomatization where
(*  ax_3a: "\<forall>w.\<exists>x. av(w)(x)" and ax_4a: "\<forall>w x. av(w)(x) \<longrightarrow> pv(w)(x)" and ax_4b: "\<forall>w. pv(w)(w)" and*)
(*  ax_5a: "\<forall>X. ob(X)(\<lambda>x. True)" and *)
  ax_1: "\<forall>X. ob(X)(X)" and (*identity*)
  ax_2: "\<forall>X Y Z. (\<forall>w. ((Y(w)) \<longleftrightarrow> (Z(w)))) \<longrightarrow> (ob(X)(Y) \<longleftrightarrow> ob(X)(Z))" and (*extension*)
  ax_3: "\<forall>X \<beta>. ((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and

(*  ax_3: "\<forall>X \<beta>. ((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and*)
  ax_5c: "\<forall>X Y Z. (((\<exists>w. (X(w) \<and> Y(w) \<and> Z(w))) \<and>  ob(X)(Y)  \<and>  ob(X)(Z))  \<longrightarrow>  ob(X)(\<lambda>w. Y(w) \<and> Z(w)))" and
  ax_5d: "\<forall>X Y Z. ((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Y) \<and> (\<forall>w. X(w) \<longrightarrow> Z(w)))
                   \<longrightarrow> ob(Z)(\<lambda>w. (Z(w) \<and> \<not>X(w)) \<or> Y(w))" and
  ax_5e: "\<forall>X Y Z. ((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Z) \<and> (\<exists>w. Y(w) \<and> Z(w))) \<longrightarrow> ob(Y)(Z)"

 abbreviation ddlneg::\<gamma> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>A \<equiv> \<lambda>w. \<not>A(w)"
 abbreviation ddland::\<rho> (infixr"\<^bold>\<and>"51) where "A\<^bold>\<and>B \<equiv> \<lambda>w. A(w)\<and>B(w)"
 abbreviation ddlor::\<rho> (infixr"\<^bold>\<or>"50) where "A\<^bold>\<or>B \<equiv> \<lambda>w. A(w)\<or>B(w)"
 abbreviation ddlimp::\<rho> (infixr"\<^bold>\<rightarrow>"49) where "A\<^bold>\<rightarrow>B \<equiv> \<lambda>w. A(w)\<longrightarrow>B(w)"
 abbreviation ddlequiv::\<rho> (infixr"\<^bold>\<leftrightarrow>"48) where "A\<^bold>\<leftrightarrow>B \<equiv> \<lambda>w. A(w)\<longleftrightarrow>B(w)"
 abbreviation ddlbox::\<gamma> ("\<^bold>\<box>") where "\<^bold>\<box>A \<equiv> \<lambda>w.\<forall>v. A(v)"  (*A = (\<lambda>w. True)*)
 abbreviation ddlboxa::\<gamma> ("\<^bold>\<box>\<^sub>a") where "\<^bold>\<box>\<^sub>aA \<equiv> \<lambda>w. (\<forall>x. av(w)(x) \<longrightarrow> A(x))"  (*in all actual worlds*)
 abbreviation ddlboxp::\<gamma> ("\<^bold>\<box>\<^sub>p") where "\<^bold>\<box>\<^sub>pA \<equiv> \<lambda>w. (\<forall>x. pv(w)(x) \<longrightarrow> A(x))" (*in all potential worlds*)
 abbreviation ddldia::\<gamma> ("\<^bold>\<diamond>") where "\<^bold>\<diamond>A \<equiv> \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>A)"
 abbreviation ddldiaa::\<gamma> ("\<^bold>\<diamond>\<^sub>a") where "\<^bold>\<diamond>\<^sub>aA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>a(\<^bold>\<not>A)"
 abbreviation ddldiap::\<gamma> ("\<^bold>\<diamond>\<^sub>p") where "\<^bold>\<diamond>\<^sub>pA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>p(\<^bold>\<not>A)"
 abbreviation ddlo::\<rho> ("\<^bold>O\<^bold>\<langle>_\<^bold>|_\<^bold>\<rangle>"[52]53) where "\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<equiv> \<lambda>w. ob(A)(B)"  (*it ought to be \<psi>, given \<phi> *)
 abbreviation ddloa::\<gamma>  ("\<^bold>O\<^sub>a") where "\<^bold>O\<^sub>aA \<equiv> \<lambda>w. ob(av(w))(A) \<and> (\<exists>x. av(w)(x) \<and> \<not>A(x))" (*actual obligation*)
 abbreviation ddlop::\<gamma>  ("\<^bold>O\<^sub>p") where "\<^bold>O\<^sub>pA \<equiv> \<lambda>w. ob(pv(w))(A) \<and> (\<exists>x. pv(w)(x) \<and> \<not>A(x))"  (*primary obligation*)
 abbreviation ddltop::\<tau> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation ddlbot::\<tau> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

(*Possibilist Quantification.*)
 abbreviation ddlforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
 abbreviation ddlforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation ddlexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
 abbreviation ddlexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

 abbreviation ddlvalid::"\<tau> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105) where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"   (*Global validity*)
 abbreviation ddlvalidcw::"\<tau> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) where "\<lfloor>A\<rfloor>\<^sub>l \<equiv> A cw" (*Local validity (in cw)*)

(* A is obliagtory *)
 abbreviation ddlobl::\<gamma> ("\<^bold>\<circle><_>") where "\<^bold>\<circle><A> \<equiv>  \<^bold>O\<^bold>\<langle>A\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"  (*New syntax: A is obligatory.*)

(* Consistency *)
 lemma True nitpick [satisfy,user_axioms,show_all] oops
end


theory ILL_predlog
imports ILL
begin

typedecl plf

consts
  conj :: "[plf,plf] => plf"   (infixr "&" 35)
  disj :: "[plf,plf] => plf"   (infixr "|" 35)
  impl :: "[plf,plf] => plf"   (infixr ">" 35)
  eq :: "[plf,plf] => plf"   (infixr "=" 35)
  ff :: "plf"    ("ff")

  PL    :: "plf => o"      ("[* / _ / *]" [] 100)

syntax
  "_NG" :: "plf => plf"   ("- _ " [50] 55)

translations

  "[* A & B *]" == "[*A*] && [*B*]"
  "[* A | B *]" == "![*A*] ++ ![*B*]"
  "[* - A *]" == "[*A > ff*]"
  "[* ff *]" == "0"
  "[* A = B *]" => "[* (A > B) & (B > A) *]"

  "[* A > B *]" == "![*A*] -o [*B*]"

(* another translations for linear implication:
  "[* A > B *]" == "!([*A*] -o [*B*])" *)

(* from [kleene 52] pp 118,119 *)

lemma k49a: "|- [* A > ( - ( - A)) *]"
  by best_safe

lemma k49b: "|- [*( - ( - ( - A))) = ( - A)*]"
  by best_safe

lemma k49c: "|- [* (A | - A) > ( - - A = A) *]"
  by best_safe

lemma k50a: "|- [* - (A = - A) *]"
  by best_power

lemma k51a: "|- [* - - (A | - A) *]"
  by best_safe

lemma k51b: "|- [* - - (- - A > A) *]"
  by best_power

lemma k56a: "|- [* (A | B) > - (- A & - B) *]"
  by best_safe

lemma k56b: "|- [* (-A | B) > - (A & -B) *]"
  by best_safe

lemma k57a: "|- [* (A & B) > - (-A | -B) *]"
  by best_safe

lemma k57b: "|- [* (A & -B) > -(-A | B) *]"
  by best_power

lemma k58a: "|- [* (A > B) > - (A & -B) *]"
  by best_safe

lemma k58b: "|- [* (A > -B) = -(A & B) *]"
  by best_safe

lemma k58c: "|- [* - (A & B) = (- - A > - B) *]"
  by best_safe

lemma k58d: "|- [* (- - A > - B) = - - (-A | -B) *]"
  by best_safe

lemma k58e: "! [* - -B > B *] |- [* (- -A > B) = (A > B) *]"
  by best_safe

lemma k58f: "! [* - -B > B *] |- [* (A > B) = - (A & -B) *]"
  by best_safe

lemma k58g: "|- [* (- -A > B) > - (A & -B) *]"
  by best_safe

lemma k59a: "|- [* (-A | B) > (A > B) *]"
  by best_safe

lemma k59b: "|- [* (A > B) > - - (-A | B) *]"
  by best_power

lemma k59c: "|- [* (-A > B) > - -(A | B) *]"
  by best_power

lemma k60a: "|- [* (A & B) > - (A > -B) *]"
  by best_safe

lemma k60b: "|- [* (A & -B) > - (A > B) *]"
  by best_safe

lemma k60c: "|- [* ( - - A & B) > - (A > -B) *]"
  by best_safe

lemma k60d: "|- [* (- - A & - B) = - (A > B) *]"
  by best_safe

lemma k60e: "|- [* - (A > B) = - (-A | B) *]"
  by best_safe

lemma k60f: "|- [* - (-A | B) = - - (A & -B) *]"
  by best_safe

lemma k60g: "|- [* - - (A > B) = - (A & -B) *]"
  by best_power

lemma k60h: "|- [* - (A & -B) = (A > - -B) *]"
  by best_safe

lemma k60i: "|- [* (A > - -B) = (- -A > - -B) *]"
  by best_safe

lemma k61a: "|- [* (A | B) > (-A > B) *]"
  by best_safe

lemma k61b: "|- [* - (A | B) = - (-A > B) *]"
  by best_power

lemma k62a: "|- [* (-A | -B) > - (A & B) *]"
  by best_safe

end


theory HashTrie
  imports Main
begin
(*-------------------------------------------HashTrie-------------------------------------------*)
type_synonym 'a array = "'a list"

definition arr_query :: "'a array \<Rightarrow> nat \<Rightarrow> 'a" ("_[_]")
  where "a[i] = a ! i"

type_synonym string = "char list"
datatype 'v hashtrie = Trie "'v option" "'v hashtrie list"
primrec h_malloc_line:: "nat \<Rightarrow> ('v hashtrie) list"
  where "h_malloc_line 0 = []"|
        "h_malloc_line (Suc n)  =  (Trie None []) # (h_malloc_line n)"
primrec h_malloc::"nat \<Rightarrow> nat \<Rightarrow> ('v hashtrie) list list"
  where"h_malloc 0 m = []"|
       "h_malloc (Suc n) m = (h_malloc_line m) # (h_malloc n m)"
definition "hashtrie_node = (h_malloc_line 256)"
definition "head_index = (h_malloc 256 256)"
lemma mal_nonempty:"n > 0 \<Longrightarrow> h_malloc_line n \<noteq> []"
  apply(induct n)
  apply simp+
  done
(* value "hashtrie_node"*)
(*value"head_index"*)

primrec "value"::"'v hashtrie \<Rightarrow> 'v option"
  where "value (Trie ov al) = ov"
primrec "alist"::"'v hashtrie \<Rightarrow> 'v hashtrie list"
  where "alist (Trie ov al) = al"

fun isless_hashlength::"nat list \<Rightarrow> string hashtrie \<Rightarrow> bool"
  where "isless_hashlength [] (Trie _ _) = True" |
        "isless_hashlength (x#xs) (Trie _ l) = (if x < length l \<and> l \<noteq> [] then isless_hashlength xs (l!x) else False)"
primrec ht_updata::"nat list \<Rightarrow> 'v hashtrie \<Rightarrow> 'v \<Rightarrow> 'v hashtrie"
  where"ht_updata [] t v= Trie (Some v) (alist t)"|
       "ht_updata (x # xs) t v=(let tt = (case (alist t)[x] of (Trie va []) \<Rightarrow>
                                            (if xs \<noteq> [] then Trie va hashtrie_node else Trie va []) |
                                               at \<Rightarrow> at)
                                in Trie (value t) (alist t[x:=(ht_updata xs tt v)]))"

fun isin_ht::"'v hashtrie \<Rightarrow> nat list \<Rightarrow> bool"
  where "isin_ht (Trie v _) [] = (if v=None then False else True)" |
        "isin_ht (Trie v l) (x#xs) = (if l = [] then False
                                     else (if (l!x) = Trie None [] then False
                                                            else isin_ht (l!x) xs))"

definition set_ht::"'v hashtrie \<Rightarrow> (nat list) set"
  where "set_ht ht = {m. isin_ht ht m}"

(*----------------------------------------Proof_HashTrie----------------------------------------*)
lemma upht_nonepmty:"\<And>ht v . m \<noteq> [] \<Longrightarrow> alist ht \<noteq> [] \<Longrightarrow> alist (ht_updata m ht v) \<noteq> []"
  apply(induct m)
  apply simp
  apply simp
  done

lemma one_isinupht:"\<And>a ht v. a < length (alist ht) \<Longrightarrow>(isin_ht (Trie (value ht) (alist ht[a := Trie (Some v) []]))) [a]"
  by auto
lemma more_one_isless:"isless_hashlength (a # m) ht = (a < length (alist ht) \<and> isless_hashlength m ((alist(ht))!a))"
  apply auto
  using isless_hashlength.elims(2) apply fastforce
  apply (metis alist.simps hashtrie.exhaust isless_hashlength.simps(2))
  by (metis alist.simps hashtrie.exhaust isless_hashlength.simps(2) list.size(3) not_less_zero)
lemma one_isless:"isless_hashlength [a] ht \<Longrightarrow> a < length (alist ht)"
  apply (induct ht)
  apply simp
  apply (split if_splits)
  apply auto
  done
lemma upht_to_ht:"x = aa#as \<Longrightarrow>
          x \<noteq> [a] \<Longrightarrow>
          isless_hashlength [a] ht \<Longrightarrow>
          isin_ht (Trie (value ht) (alist ht[a := Trie (Some v) []])) x \<Longrightarrow>  isin_ht ht x"
  apply simp
  apply (split if_splits)
  apply simp
  apply (split if_splits)
  apply auto
  using isin_ht.elims(3) apply fastforce
  apply (case_tac \<open>aa=a\<close>)
  apply simp
  using isin_ht.elims(2) one_isless apply fastforce
  using isin_ht.elims(3) by fastforce
lemma newstr_more_two:"isless_hashlength (a # m) ht \<Longrightarrow> alist ht[a] = Trie va h \<Longrightarrow> m \<noteq> [] \<Longrightarrow> h = [] \<Longrightarrow>
        set_ht (Trie (value ht) (alist ht[a := ht_updata m (Trie va hashtrie_node) v])) = insert (a # m) (set_ht ht)"
  by (metis (no_types, lifting) alist.simps gr_implies_not0 isless_hashlength.elims(2)
       list.distinct(1) list.sel(3) list.size(3) nth_Cons_0 arr_query_def)
lemma newstr_only_one:" isless_hashlength (a # m) ht \<Longrightarrow> alist ht[a] = Trie va h \<Longrightarrow>  \<not> m \<noteq> [] \<Longrightarrow> h = [] \<Longrightarrow>
        set_ht (Trie (value ht) (alist ht[a := ht_updata m (Trie va []) v])) = insert (a # m) (set_ht ht)"
  apply(simp add:set_ht_def arr_query_def)
  by(smt Collect_cong alist.simps one_isinupht insert_Collect isin_ht.elims(2) isin_ht.simps(1)
          isin_ht.simps(2) isless_hashlength.elims(2) one_isless nth_list_update_neq upht_to_ht value.simps)
lemma newstr_more_one: "(\<And>ht v. isless_hashlength m ht \<Longrightarrow> set_ht (ht_updata m ht v) = insert m (set_ht ht)) \<Longrightarrow>
        isless_hashlength (a # m) ht \<Longrightarrow> h = h1 # h2 \<Longrightarrow> alist ht[a] = Trie va (h1 # h2) \<Longrightarrow>
        set_ht (Trie (value ht) (alist ht[a := ht_updata m (Trie va (h1 # h2)) v])) = insert (a # m) (set_ht ht)"
  apply (auto simp:set_ht_def arr_query_def)
  apply (smt alist.simps insert_iff isin_ht.elims(2) isin_ht.elims(3) isless_hashlength.elims(2) list.distinct(1)
            list.sel(3) mem_Collect_eq nth_Cons_0 nth_list_update_eq nth_list_update_neq value.simps)
  apply (smt alist.simps insertI1 isin_ht.simps(1) isless_hashlength.elims(2) list.distinct(1)
            list.sel(3) mem_Collect_eq nth_Cons_0 nth_list_update_eq upht_nonepmty)
  using isless_hashlength.elims(2) apply fastforce
  apply (smt alist.simps insertCI isless_hashlength.elims(2) list.distinct(1)
            list.sel(3) mem_Collect_eq nth_Cons_0 nth_list_update_eq)
  by (smt alist.simps insertCI isin_ht.elims(2) isin_ht.elims(3) isless_hashlength.elims(2) list.discI
            list.inject list_update_nonempty mem_Collect_eq nth_list_update_eq nth_list_update_neq value.simps)
theorem upht_correct:"\<And>hashtrie v. isless_hashlength new_str hashtrie \<Longrightarrow>
                    set_ht (ht_updata new_str hashtrie v) = {new_str} \<union> set_ht hashtrie"
  apply (induct new_str)
  apply (simp add:set_ht_def,smt Collect_cong alist.simps insert_Collect isin_ht.elims(2)
          isin_ht.elims(3) isin_ht.simps(1) list.inject option.discI)
  apply(simp ,split hashtrie.splits,rule allI,rule allI,split list.splits)
  using newstr_more_two newstr_only_one newstr_more_one by auto

thm isless_hashlength.elims
definition "kw2 = [0::nat,0,1,1]"

fun uphead::"nat list \<Rightarrow> (string hashtrie) list list \<Rightarrow> string \<Rightarrow> (string hashtrie) list list"
  where "uphead (f#s#l) h v = (let tt = (case h[f][s] of (Trie va []) => Trie va hashtrie_node |
                                            at \<Rightarrow> at) in h[f:=(h[f])[s:=ht_updata l tt v]])"
primrec head_hash_table::"nat list list \<Rightarrow> string list \<Rightarrow> (string hashtrie) list list \<Rightarrow> (string hashtrie) list list"
  where "head_hash_table [] vs h = h"|
        "head_hash_table (x#xs) vs h = (let l = (if ((x[0])>128) then x
                                       else (x[0])#x) in head_hash_table xs (tl vs) (uphead l h (hd vs)))"

primrec find_p::"nat list \<Rightarrow> string hashtrie \<Rightarrow> string hashtrie option"
  where "find_p [] t = Some t"|
        "find_p (x#xs) t = (if alist t = [] then None
                                  else (case (alist t)[x] of Trie None [] \<Rightarrow> None |
                                                     Trie _ _ \<Rightarrow> find_p xs ((alist t)!x)))"

(*----------------------------------------Violent Matching----------------------------------------*)
fun c_vmatching::"nat list \<Rightarrow> string hashtrie \<Rightarrow> string list \<Rightarrow> string list"
  where "c_vmatching [] ht p = (case (value ht) of Some v \<Rightarrow> (v#p) |
                                        None \<Rightarrow> p)" |
         "c_vmatching (x#[]) ht p = (case (value ht) of Some v \<Rightarrow> (v#p) |
                                             None \<Rightarrow> p)"|
         "c_vmatching (x#n#xs) ht p = (case (value ht) of Some v \<Rightarrow> (v#p)|
                                          None \<Rightarrow> (case (find_p [x,n] ht) of None \<Rightarrow> p|
                                                                      (Some ht') \<Rightarrow> c_vmatching xs ht' p))"
primrec e_vmatching::"nat list \<Rightarrow> string hashtrie \<Rightarrow> string list \<Rightarrow> string list"
  where"e_vmatching [] ht p = (case (value ht) of Some v \<Rightarrow> (p@[v]) |
                                        None \<Rightarrow>  p)"|
        "e_vmatching (x#xs) ht p = (case (value ht) of Some v \<Rightarrow> (p@[v]) |
                                           None \<Rightarrow> (case find_p [x] ht of None \<Rightarrow> p|
                                                                    Some ht' \<Rightarrow> e_vmatching xs ht' p))"
fun vmatching::"nat list \<Rightarrow> string hashtrie list list \<Rightarrow> string list \<Rightarrow> string list"
  where"vmatching [] h p = p"|
       "vmatching (x#xs) h p = (if x>128 \<and> length xs \<ge> 3
                          then (case xs of (xx#a#aa#as) \<Rightarrow>
                                     (case find_p [a,aa] (h[x][xx]) of None \<Rightarrow> vmatching (a#aa#as) h p |
                                                              Some ht \<Rightarrow>
                                        (let n_p = c_vmatching as ht p in vmatching (a#aa#as) h n_p)))
                           else (if x>128 \<and> length xs < 3 then p
                               else (case xs of [] \<Rightarrow> p| (xx#as) \<Rightarrow>
(case find_p [xx] (h[x][x]) of None \<Rightarrow> vmatching xs h p |
                                                                   Some ht \<Rightarrow>
                                                      (let n_p = e_vmatching as ht p in vmatching xs h n_p)))))"

(*----------------------------------------Threaded HashTrie----------------------------------------*)
definition find_prefix::"nat list \<Rightarrow> (string hashtrie) list list \<Rightarrow> string hashtrie option"
  where "find_prefix k h = (case k of (x#xs) \<Rightarrow> (if (x > 128) then find_p (tl xs) (h[x][(hd xs)])
                                                  else find_p xs (h!x!x)))"

definition c_findex_line::"nat list \<Rightarrow> nat list list  \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list"
  where "c_findex_line k ks h = (case k of x#s#xs \<Rightarrow>
                                  c_findex_l (drop 2 xs) (take 2 xs) ks [([], Trie None []),([], Trie None []),([], Trie None []),([], Trie None [])] h)"
(*Chinese*)
primrec findex::"nat list list \<Rightarrow> nat list list \<Rightarrow> (nat list \<times> string hashtrie) list list  \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list list"
  where "findex [] ks f h = f"|
        "findex (x#xs) ks f h =(let l = (if (hd x) > 128 then (f@[(c_findex_line x (ks@xs) h)])
                                               else  (f@[(e_findex_line x (ks@xs) h)])) in findex xs (ks@[x]) l h)"
lemma findex_append_nil:"\<And>ks f h. findex l ks f h = f@(findex l ks [] h)"
  apply (induct l)
  apply simp
proof -
fix a :: "nat list" and la :: "nat list list" and ks :: "nat list list" and f :: "(nat list \<times> char list hashtrie) list list" and h :: "char list hashtrie list list"
  assume a1: "\<And>ks f h. findex la ks f h = f @ findex la ks [] h"
  have f2: "\<forall>ns nss nssa pss hss. if 128 < hd ns then findex (ns # nss) nssa pss hss = findex nss (nssa @ [ns]) (pss @ [c_findex_line ns (nssa @ nss) hss]) hss else findex (ns # nss) nssa pss hss = findex nss (nssa @ [ns]) (pss @ [e_findex_line ns (nssa @ nss) hss]) hss"
    using findex.simps(2) by presburger
  then have f3: "\<not> 128 < hd a \<longrightarrow> findex (a # la) ks f h = (f @ [e_findex_line a (ks @ la) h]) @ findex la (ks @ [a]) [] h"
    using a1 by metis
  { assume "findex (a # la) ks f h \<noteq> f @ findex (a # la) ks [] h"
    moreover
    {assume "findex (a # la) ks f h \<noteq> f @ [c_findex_line a (ks @ la) h] @ findex la (ks @ [a]) [] h"
  then have "findex (a # la) ks f h \<noteq> findex la (ks @ [a]) (f @ [c_findex_line a (ks @ la) h]) h"
  using a1 by (metis (no_types) append.assoc)
  then have "\<not> 128 < hd a"
  using f2 by meson }
  ultimately have "findex (a # la) ks f h = f @ findex (a # la) ks [] h"
  using f3 f2 a1 by (metis append.assoc append_Nil) }
then show "findex (a # la) ks f h = f @ findex (a # la) ks [] h"
  by meson
qed

lemma findex_c_c:"i < Suc (length l) \<Longrightarrow> 128 < hd ((a # l)[i]) \<Longrightarrow> 128 < hd a \<Longrightarrow>
       (\<And>i h p. i < length l \<Longrightarrow> 128 < hd (l[i]) \<Longrightarrow> findex l p [] h[i] = c_findex_line (l[i]) (p @ take i l @ drop (Suc i) l) h) \<Longrightarrow>
       findex l (p @ [a]) [c_findex_line a (p @ l) h] h[i] = c_findex_line ((a # l)[i]) (p @ take i (a # l) @ drop i l) h"
  apply (case_tac "i = 0")
  apply (metis append_Cons drop_0 findex_append_nil nth_Cons_0 self_append_conv2 take_0 arr_query_def)
  by (metis (no_types, lifting) append.assoc append_Cons append_Nil findex_append_nil less_Suc_eq_0_disj nth_Cons_Suc take_Suc_Cons arr_query_def)
lemma findex_c_e:"\<lbrakk>i < Suc (length l); 128 < hd ((a # l)[i]); \<not> 128 < hd a;
       (\<And>i h p. \<lbrakk>i < length l; 128 < hd (l[i])\<rbrakk> \<Longrightarrow> findex l p [] h[i] = c_findex_line (l[i]) (p @ take i l @ drop (Suc i) l) h)\<rbrakk> \<Longrightarrow>
        findex l (p @ [a]) [e_findex_line a (p @ l) h] h[i] = c_findex_line ((a # l)[i]) (p @ take i (a # l) @ drop i l) h"
  by (smt append.assoc append_Cons findex_append_nil less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc self_append_conv2 take_Suc_Cons arr_query_def)
theorem findex_c:"\<And>i h p. \<lbrakk>i < length l ; hd (l[i]) > 128\<rbrakk> \<Longrightarrow>
               (findex l p [] h)[i] = c_findex_line (l[i]) (p@(take i l)@(drop (i+1) l)) h"
  apply(induct l)
  apply (simp add:arr_query_def)
  apply (simp(no_asm_simp))
  apply (case_tac "i = 0")
  apply (metis append_Cons drop_0 findex_append_nil nth_Cons_0 self_append_conv2 take_0 arr_query_def)
  by (simp add: findex_c_c findex_c_e)
lemma findex_e_c:"(\<And>i h p. i < length l \<Longrightarrow> \<not> 128 < hd (l[i]) \<Longrightarrow> findex l p [] h[i] = e_findex_line (l[i]) (p @ take i l @ drop (Suc i) l) h) \<Longrightarrow>
       i < Suc (length l) \<Longrightarrow>
       \<not> 128 < hd ((a # l)[i]) \<Longrightarrow> 128 < hd a \<Longrightarrow> findex l (p @ [a]) [c_findex_line a (p @ l) h] h[i] = e_findex_line ((a # l)[i]) (p @ take i (a # l) @ drop i l) h"
  apply (case_tac "i = 0")
  apply (simp add:arr_query_def)
  by (metis (no_types, lifting) append.assoc append_Cons append_Nil findex_append_nil less_Suc_eq_0_disj nth_Cons_Suc take_Suc_Cons arr_query_def)
lemma findex_e_e:"(\<And>i h p. i < length l \<Longrightarrow> \<not> 128 < hd (l[i]) \<Longrightarrow> findex l p [] h[i] = e_findex_line (l[i]) (p @ take i l @ drop (Suc i) l) h) \<Longrightarrow> i < Suc (length l) \<Longrightarrow> \<not> 128 < hd ((a # l)[i]) \<Longrightarrow>
       \<not> 128 < hd a \<Longrightarrow> findex l (p @ [a]) [e_findex_line a (p @ l) h] h[i] = e_findex_line ((a # l)[i]) (p @ take i (a # l) @ drop i l) h"
  apply (case_tac "i = 0")
  apply (metis append.right_neutral append_Cons append_assoc drop_0 findex_append_nil nth_Cons_0 take_0 arr_query_def)
  by (smt append.assoc append_Cons findex_append_nil less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc self_append_conv2 take_Suc_Cons arr_query_def)
lemma findex_e:"\<And>i h p. \<lbrakk>i < length l ; \<not> hd (l[i]) > 128\<rbrakk> \<Longrightarrow>  (findex l p [] h)[i] = e_findex_line (l[i]) (p@(take i l)@(drop (i+1) l)) h"
  apply(induct l)
  apply simp
  by (simp add:findex_e_c findex_e_e)
(*findex*)

(*sindex*)
(*English*)
primrec e_sindex_l::"nat list \<Rightarrow> nat list \<Rightarrow> nat list list\<Rightarrow> (nat list \<times> string hashtrie) list \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list "
  where"e_sindex_l [] p ks s h = (let i = (case e_common_pre_suf p ks of None \<Rightarrow> ([], Trie None [])|
                                                            Some n \<Rightarrow> (n,the (find_prefix n h)))
                                      in (butlast s@[i]))"|
       "e_sindex_l (x#xs) p ks s h = e_sindex_l xs (p@[x]) ks (s@[([], Trie None [])]) h"
definition e_sindex_line::"nat list \<Rightarrow> nat list list  \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list"
  where "e_sindex_line k ks h = (case k of x#s#xs \<Rightarrow> e_sindex_l  xs [s] ks [([], Trie None []),([], Trie None [])] h)"
(*English*)
(*Chinese*)
fun c_sindex_l::"nat list \<Rightarrow> nat list \<Rightarrow> nat list list \<Rightarrow> (nat list \<times> string hashtrie) list
          => (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list "
  where "c_sindex_l [] p ks s h = (let i = (case c_common_pre_suf p ks of None \<Rightarrow> ([], Trie None [])|
                                                             Some n \<Rightarrow> (n,the (find_prefix n h)))
                                      in (butlast s@[i]))"|
        "c_sindex_l (x#m#xs) p ks s h = c_sindex_l xs (p@[x,m]) ks (s@[([], Trie None []),([], Trie None [])]) h"
definition c_sindex_line::"nat list \<Rightarrow> nat list list  \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list"
  where "c_sindex_line k ks h = (case k of x#s#n#m#xs \<Rightarrow>
                                  c_sindex_l  xs [n,m] ks [([], Trie None []),([], Trie None []),([], Trie None []),([], Trie None [])] h)"
(*Chinese*)
primrec sindex::"nat list list \<Rightarrow> nat list list \<Rightarrow> (nat list \<times> string hashtrie) list list  \<Rightarrow> (string hashtrie) list list \<Rightarrow> (nat list \<times> string hashtrie) list list"
  where "sindex [] ks s h = s"|
        "sindex (x#xs) ks s h =(let l = (if (hd x) > 128 then (s@[(c_sindex_line x (ks@xs) h)])
                                               else  (s@[(e_sindex_line x (ks@xs) h)])) in sindex xs (ks@[x]) l h)"
(*sindex*)

(*----------------------------------------Functional Multi Pattern Matching----------------------------------------*)
primrec kw_n:: "nat list \<Rightarrow>  nat list list \<Rightarrow> nat \<Rightarrow> nat option"
  where"kw_n p [] n = None"|
       "kw_n p (x#xs) n = (if (take (length p) x) = p then Some n else kw_n p xs (Suc n))"
value "kw_n [2,3] kw3 0"
(*Chinese*)
fun c_FMPM ::"nat list \<Rightarrow> nat list \<Rightarrow> nat list list \<Rightarrow> string hashtrie  \<Rightarrow> (nat list \<times> string hashtrie) list list \<Rightarrow>
             (nat list \<times> string hashtrie) list list \<Rightarrow> string list \<Rightarrow> nat list \<Rightarrow> (nat list \<times> string list)"
where
      "c_FMPM [] pre ks ht s f p ps =  (case ht of Trie (Some v) _ \<Rightarrow> (ps, (p@[v])) |
                                                  Trie None _ \<Rightarrow> (ps, p))" |
      "c_FMPM (x#[]) pre ks ht s f p ps = (case ht of Trie (Some v) _ \<Rightarrow> (ps, (p@[v])) |
                                                  Trie None _ \<Rightarrow> (ps, p))" |
      "c_FMPM (x#n#xs) pre ks ht s f p ps =  (let kn = the (kw_n pre ks 0)
          in (case (value ht) of Some v \<Rightarrow>
  (let (s_m, s_ht) = s[kn][(length pre - 1)]; s_pre = drop (length pre - length s_m) pre
in(if length s_m > 0 \<and> length s_m < length pre then c_FMPM (x#n#xs) s_pre ks s_ht s f (p@[v]) ps
                                                       else (ps, (p@[v]))))|
                            None \<Rightarrow> (case find_p [x,n] ht of None \<Rightarrow>
              (let (f_m, f_ht) = f[kn][(length pre)]; f_pre = drop (length pre - length f_m) pre
              in (if  length f_m > 0 \<and> length f_m < length pre then c_FMPM (x#n#xs) f_pre ks f_ht s f p ps
else (ps, p)))|
                                               Some ht' \<Rightarrow> c_FMPM xs (pre@[x,n]) ks ht' s f p (ps@[x,n]))))"
lemma c_FMPM_value_append:"\<And>ps. fst (c_FMPM c_ts pre ks ht s f p (ps@pa)) = ps@(fst (c_FMPM c_ts pre ks ht s f p pa))"
  apply (induct c_ts pre ks ht s f p pa  rule:c_FMPM.induct)
  apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
  apply auto[1]
  apply (rule allI)
   apply auto[1]
   apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
   apply auto[1]
   apply auto[1]
   apply (simp(no_asm_simp))
   apply (simp(no_asm_simp) only:Let_def,split option.split,rule conjI)
   apply (rule impI,split option.split,rule conjI)
   apply (rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
   apply (rule impI)
   using old.prod.case option.simps(4) apply auto[1]
   apply (rule impI)
   using old.prod.case option.simps(4) apply auto[1]
   apply (rule allI,rule impI)
   using old.prod.case option.simps(4) apply auto[1]
   apply (rule allI,rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
   apply (rule impI)
   using old.prod.case option.simps(4) apply auto[1]
   apply (rule impI)
using old.prod.case option.simps(4) apply auto[1]
  done
lemma c_FMPM_length:"length (fst (c_FMPM c_ts pre ks ht s f p ps)) \<ge> length ps"
  apply (induct c_ts pre ks ht s f p ps rule:c_FMPM.induct)
  apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
  apply auto[1]
  apply (rule allI)
  apply auto[1]
  apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
  apply auto[1]
  apply (rule allI)
  apply auto[1]
  apply (simp(no_asm_simp))
  apply (simp(no_asm_simp) only:Let_def,split option.split,rule conjI)
  apply (rule impI,split option.split,rule conjI)
  apply (rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  apply presburger
  apply (rule impI)
  apply simp
  apply (rule allI,rule impI)
  using add_Suc_right le_SucI length_append apply force
  apply (rule allI,rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  apply presburger
  apply (rule impI)
  apply simp
  done
(*English*)
fun e_FMPM::"nat list \<Rightarrow> nat list \<Rightarrow> nat list list \<Rightarrow> string hashtrie  \<Rightarrow> (nat list \<times> string hashtrie) list list \<Rightarrow>
            (nat list \<times> string hashtrie) list list \<Rightarrow> string list \<Rightarrow> nat list \<Rightarrow> (nat list \<times> string list)"
where "e_FMPM [] pre ks ht s f p ps =  (case ht of Trie (Some v) _ \<Rightarrow> (ps, (p@[v])) |
                                                  Trie None _ \<Rightarrow> (ps, p))" |
      "e_FMPM (x#xs) pre ks ht s f p ps = (let kn = the (kw_n pre ks 0)
               in (case (value ht) of (Some v) \<Rightarrow>
(let (s_m, s_ht) = s[kn][(length pre - 1)]; s_pre = drop (length pre - length s_m) pre
                    in(if s_m \<noteq> [] \<and> length s_m < length pre then e_FMPM (x#xs) s_pre ks s_ht s f (p@[v]) ps
                                                         else (ps, (p@[v]))))|
                                  None \<Rightarrow> (case find_p [x] ht of None \<Rightarrow>
                     (let (f_m, f_ht) = f[kn][(length pre)]; f_pre = drop (length pre - length f_m) pre
                     in (if f_m \<noteq> [] \<and> length f_m < length pre
then e_FMPM (x#xs) f_pre ks f_ht s f p ps else (ps, p)))|
                                                           Some ht' \<Rightarrow>
e_FMPM xs (pre@[x]) ks ht' s f p (ps@[x])) ))"
lemma e_FMPM_append:"\<And>ps. fst (e_FMPM c_ts pre ks ht s f p (ps@pa)) =  ps@(fst (e_FMPM c_ts pre ks ht s f p pa))"
  apply (induct c_ts pre ks ht s f p pa  rule:e_FMPM.induct)
  apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
  apply auto[1]
  apply (rule allI)
  apply auto[1]
  apply (simp(no_asm_simp))
  apply (simp(no_asm_simp) only:Let_def,split option.split,rule conjI)
  apply (rule impI,split option.split,rule conjI)
  apply (rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  using old.prod.case option.simps(4) apply auto[1]
  apply (rule impI)
  using old.prod.case option.simps(4) apply auto[1]
  apply (rule allI,rule impI)
  using add_Suc_right le_SucI length_append apply force
  apply (rule allI,rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  using old.prod.case option.simps(4) apply auto[1]
  apply (rule impI)
  using old.prod.case option.simps(4) apply auto[1]
  done
lemma e_FMPM_length:"length (fst (e_FMPM c_ts pre ks ht s f p ps)) \<ge> length ps"
  apply (induct c_ts pre ks ht s f p ps rule:e_FMPM.induct)
  apply (simp,split hashtrie.split,split option.split,rule allI,rule conjI)
  apply auto[1]
  apply (rule allI)
  apply auto[1]
  apply (simp(no_asm_simp))
  apply (simp(no_asm_simp) only:Let_def,split option.split,rule conjI)
  apply (rule impI,split option.split,rule conjI)
  apply (rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  apply presburger
  apply (rule impI)
apply simp
  apply (rule allI,rule impI)
  using add_Suc_right le_SucI length_append apply force
  apply (rule allI,rule impI,split prod.split,rule allI,rule allI,rule impI,split if_split,rule conjI)
  apply (rule impI)
  apply presburger
  apply (rule impI)
  apply simp
  done
fun FMPM::"nat list \<Rightarrow> nat list list \<Rightarrow>string hashtrie list list  \<Rightarrow> string list \<Rightarrow> string list"
  where"FMPM [] ks h p = p"|
       "FMPM (x#xs) ks h p = (if x>128 \<and> length xs \<ge> 3
                           then (case xs of (xx#a#aa#as) \<Rightarrow>
                                    (case find_p [a,aa] (h[x][xx]) of None \<Rightarrow> FMPM (a#aa#as) ks h p|
                                                             Some ht \<Rightarrow>
                             (let (i, n_p) = c_FMPM as [x,xx,a,aa] ks ht (sindex ks [] [] h) (findex ks [] [] h) p []
                             in ( FMPM (drop (length i) as) ks h n_p))))
                            else (if x>128 \<and> length xs < 3 then p
                                                       else (case xs of [] \<Rightarrow> p|
                                                             xx#as \<Rightarrow> (case find_p [xx] (h!x!x) of None \<Rightarrow>
                                                                      FMPM xs ks h p |
                                                                                Some ht \<Rightarrow>
                                  (let (i, n_p) = e_FMPM as [x,xx] ks ht (sindex ks [] [] h) (findex ks [] [] h) p []
                                  in (FMPM (drop (length i) (as)) ks h n_p))))))"

end