(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>Interleaving of concurrent insertions\<close>

text\<open>In this section we prove that our list specification rules out
interleaving of concurrent insertion sequences starting at the same position.\<close>

theory Interleaving
  imports Insert_Spec
begin

subsection\<open>Lemmas about \isa{insert-ops}\<close>

lemma map_fst_append1:
  assumes "\<forall>i \<in> set (map fst xs). P i"
    and "P x"
  shows "\<forall>i \<in> set (map fst (xs @ [(x, y)])). P i"
using assms by (induction xs, auto)

lemma insert_ops_split:
  assumes "insert_ops ops"
    and "(oid, ref) \<in> set ops"
  shows "\<exists>pre suf. ops = pre @ [(oid, ref)] @ suf \<and>
            (\<forall>i \<in> set (map fst pre). i < oid) \<and>
            (\<forall>i \<in> set (map fst suf). oid < i)"
using assms proof(induction ops rule: List.rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  then show ?case
  proof(cases "x = (oid, ref)")
    case True
    moreover from this have "\<forall>i \<in> set (map fst xs). i < oid"
      using last_op_greatest snoc.prems(1) by blast
    ultimately have "xs @ [x] = xs @ [(oid, ref)] @ [] \<and>
            (\<forall>i \<in> set (map fst xs). i < oid) \<and>
            (\<forall>i \<in> set (map fst []). oid < i)"
      by auto
    then show ?thesis by force
  next
    case False
    hence "(oid, ref) \<in> set xs"
      using snoc.prems(2) by auto
    from this obtain pre suf where IH: "xs = pre @ [(oid, ref)] @ suf \<and>
         (\<forall>i \<in> set (map fst pre). i < oid) \<and>
         (\<forall>i \<in> set (map fst suf). oid < i)"
      using snoc.IH snoc.prems(1) by blast
    obtain xi xr where x_pair: "x = (xi, xr)"
      by force
    hence "distinct (map fst (pre @ [(oid, ref)] @ suf @ [(xi, xr)]))"
      by (metis IH append.assoc insert_ops_def spec_ops_def snoc.prems(1))
    hence "xi \<noteq> oid"
      by auto
    have xi_max: "\<forall>x \<in> set (map fst (pre @ [(oid, ref)] @ suf)). x < xi"
      using IH last_op_greatest snoc.prems(1) x_pair by blast
    then show ?thesis
    proof(cases "xi < oid")
      case True
      moreover from this have "\<forall>x \<in> set suf. fst x < oid"
        using xi_max by auto
      hence "suf = []"
        using IH last_in_set by fastforce
      ultimately have "xs @ [x] = (pre @ [(xi, xr)]) @ [] \<and>
              (\<forall>i \<in> set (map fst ((pre @ [(xi, xr)]))). i < oid) \<and>
              (\<forall>i \<in> set (map fst []). oid < i)"
        using dual_order.asym xi_max by auto
      then show ?thesis by (simp add: IH)
    next
      case False
      hence "oid < xi"
        using \<open>xi \<noteq> oid\<close> by auto
      hence "\<forall>i \<in> set (map fst (suf @ [(xi, xr)])). oid < i"
        using IH map_fst_append1 by auto
      hence "xs @ [x] = pre @ [(oid, ref)] @ (suf @ [(xi, xr)]) \<and>
              (\<forall>i \<in> set (map fst pre). i < oid) \<and>
              (\<forall>i \<in> set (map fst (suf @ [(xi, xr)])). oid < i)"
        by (simp add: IH x_pair)
      then show ?thesis by blast
    qed
  qed
qed

lemma insert_ops_split_2:
  assumes "insert_ops ops"
    and "(xid, xr) \<in> set ops"
    and "(yid, yr) \<in> set ops"
    and "xid < yid"
  shows "\<exists>as bs cs. ops = as @ [(xid, xr)] @ bs @ [(yid, yr)] @ cs \<and>
           (\<forall>i \<in> set (map fst as). i < xid) \<and>
           (\<forall>i \<in> set (map fst bs). xid < i \<and> i < yid) \<and>
           (\<forall>i \<in> set (map fst cs). yid < i)"
proof -
  obtain as as1 where x_split: "ops = as @ [(xid, xr)] @ as1 \<and>
      (\<forall>i \<in> set (map fst as). i < xid) \<and> (\<forall>i \<in> set (map fst as1). xid < i)"
    using assms insert_ops_split by blast
  hence "insert_ops ((as @ [(xid, xr)]) @ as1)"
    using assms(1) by auto
  hence "insert_ops as1"
    using assms(1) insert_ops_rem_prefix by blast
  have "(yid, yr) \<in> set as1"
    using x_split assms by auto
  from this obtain bs cs where y_split: "as1 = bs @ [(yid, yr)] @ cs \<and>
      (\<forall>i \<in> set (map fst bs). i < yid) \<and> (\<forall>i \<in> set (map fst cs). yid < i)"
    using assms insert_ops_split \<open>insert_ops as1\<close> by blast
  hence "ops = as @ [(xid, xr)] @ bs @ [(yid, yr)] @ cs"
    using x_split by blast
  moreover have "\<forall>i \<in> set (map fst bs). xid < i \<and> i < yid"
    by (simp add: x_split y_split)
  ultimately show ?thesis
    using x_split y_split by blast
qed

lemma insert_ops_sorted_oids:
  assumes "insert_ops (xs @ [(i1, r1)] @ ys @ [(i2, r2)])"
  shows "i1 < i2"
proof -
  have "\<And>i. i \<in> set (map fst (xs @ [(i1, r1)] @ ys)) \<Longrightarrow> i < i2"
    by (metis append.assoc assms last_op_greatest)
  moreover have "i1 \<in> set (map fst (xs @ [(i1, r1)] @ ys))"
    by auto
  ultimately show "i1 < i2"
    by blast
qed

lemma insert_ops_subset_last:
  assumes "insert_ops (xs @ [x])"
    and "insert_ops ys"
    and "set ys \<subseteq> set (xs @ [x])"
    and "x \<in> set ys"
  shows "x = last ys"
using assms proof(induction ys, simp)
  case (Cons y ys)
  then show "x = last (y # ys)"
  proof(cases "ys = []")
    case True
    then show "x = last (y # ys)"
      using Cons.prems(4) by auto
  next
    case ys_nonempty: False
    have "x \<noteq> y"
    proof -
      obtain mid l where "ys = mid @ [l]"
        using append_butlast_last_id ys_nonempty by metis
      moreover obtain li lr where "l = (li, lr)"
        by force
      moreover have "\<And>i. i \<in> set (map fst (y # mid)) \<Longrightarrow> i < li"
        by (metis last_op_greatest Cons.prems(2) calculation append_Cons)
      hence "fst y < li"
        by simp
      moreover have "\<And>i. i \<in> set (map fst xs) \<Longrightarrow> i < fst x"
        using assms(1) last_op_greatest by (metis prod.collapse)
      hence "\<And>i. i \<in> set (map fst (y # ys)) \<Longrightarrow> i \<le> fst x"
        using Cons.prems(3) by fastforce
      ultimately show "x \<noteq> y"
        by fastforce
    qed
    then show "x = last (y # ys)"
      using Cons.IH Cons.prems insert_ops_rem_cons ys_nonempty
      by (metis dual_order.trans last_ConsR set_ConsD set_subset_Cons)
  qed
qed

lemma subset_butlast:
  assumes "set xs \<subseteq> set (ys @ [y])"
    and "last xs = y"
    and "distinct xs"
  shows "set (butlast xs) \<subseteq> set ys"
using assms by (induction xs, auto)

lemma distinct_append_butlast2:
  assumes "distinct (map fst xs @ map fst ys)"
  shows "distinct (map fst xs @ map fst (butlast ys))"
using assms proof(induction xs)
  case Nil
  then show "distinct (map fst [] @ map fst (butlast ys))"
    by (simp add: distinct_butlast map_butlast)
next
  case (Cons a xs)
  have "fst a \<notin> set (map fst xs @ map fst ys)"
    using Cons.prems by auto
  moreover have "set (map fst (butlast ys)) \<subseteq> set (map fst ys)"
    by (metis in_set_butlastD map_butlast subsetI)
  hence "set (map fst xs @ map fst (butlast ys)) \<subseteq> set (map fst xs @ map fst ys)"
    by auto
  ultimately have "fst a \<notin> set (map fst xs @ map fst (butlast ys))"
    by blast
  then show ?case
    using Cons.IH Cons.prems by auto
qed

subsection\<open>Lemmas about \isa{interp-ins}\<close>

lemma interp_ins_maybe_grow:
  assumes "insert_ops (xs @ [(oid, ref)])"
  shows "set (interp_ins (xs @ [(oid, ref)])) = set (interp_ins xs) \<or>
         set (interp_ins (xs @ [(oid, ref)])) = (set (interp_ins xs) \<union> {oid})"
by (cases ref, simp add: interp_ins_tail_unfold,
    metis insert_spec_nonex insert_spec_set interp_ins_tail_unfold)

lemma interp_ins_maybe_grow2:
  assumes "insert_ops (xs @ [x])"
  shows "set (interp_ins (xs @ [x])) = set (interp_ins xs) \<or>
         set (interp_ins (xs @ [x])) = (set (interp_ins xs) \<union> {fst x})"
using assms interp_ins_maybe_grow by (cases x, auto)

lemma interp_ins_maybe_grow3:
  assumes "insert_ops (xs @ ys)"
  shows "\<exists>A. A \<subseteq> set (map fst ys) \<and> set (interp_ins (xs @ ys)) = set (interp_ins xs) \<union> A"
using assms proof(induction ys rule: List.rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x ys)
  then have "insert_ops (xs @ ys)"
    by (metis append_assoc insert_ops_rem_last)
  then obtain A where IH: "A \<subseteq> set (map fst ys) \<and>
            set (interp_ins (xs @ ys)) = set (interp_ins xs) \<union> A"
    using snoc.IH by blast
  then show ?case
  proof(cases "set (interp_ins (xs @ ys @ [x])) = set (interp_ins (xs @ ys))")
    case True
    moreover have "A \<subseteq> set (map fst (ys @ [x]))"
      using IH by auto
    ultimately show ?thesis
      using IH by auto
  next
    case False
    then have "set (interp_ins (xs @ ys @ [x])) = set (interp_ins (xs @ ys)) \<union> {fst x}"
      by (metis append_assoc interp_ins_maybe_grow2 snoc.prems)
    moreover have "A \<union> {fst x} \<subseteq> set (map fst (ys @ [x]))"
      using IH by auto
    ultimately show ?thesis
      using IH Un_assoc by metis
  qed
qed

lemma interp_ins_ref_nonex:
  assumes "insert_ops ops"
    and "ops = xs @ [(oid, Some ref)] @ ys"
    and "ref \<notin> set (interp_ins xs)"
  shows "oid \<notin> set (interp_ins ops)"
using assms proof(induction ys arbitrary: ops rule: List.rev_induct)
  case Nil
  then have "interp_ins ops = insert_spec (interp_ins xs) (oid, Some ref)"
    by (simp add: interp_ins_tail_unfold)
  moreover have "\<And>i. i \<in> set (map fst xs) \<Longrightarrow> i < oid"
    using Nil.prems last_op_greatest by fastforce
  hence "\<And>i. i \<in> set (interp_ins xs) \<Longrightarrow> i < oid"
    by (meson interp_ins_subset subsetCE)
  ultimately show "oid \<notin> set (interp_ins ops)"
    using assms(3) by auto
next
  case (snoc x ys)
  then have "insert_ops (xs @ (oid, Some ref) # ys)"
    by (metis append.assoc append.simps(1) append_Cons insert_ops_appendD)
  hence IH: "oid \<notin> set (interp_ins (xs @ (oid, Some ref) # ys))"
    by (simp add: snoc.IH snoc.prems(3))
  moreover have "distinct (map fst (xs @ (oid, Some ref) # ys @ [x]))"
    using snoc.prems by (metis append_Cons append_self_conv2 insert_ops_def spec_ops_def)
  hence "fst x \<noteq> oid"
    using empty_iff by auto
  moreover have "insert_ops ((xs @ (oid, Some ref) # ys) @ [x])"
    using snoc.prems by auto
  hence "set (interp_ins ((xs @ (oid, Some ref) # ys) @ [x])) =
         set (interp_ins (xs @ (oid, Some ref) # ys)) \<or>
         set (interp_ins ((xs @ (oid, Some ref) # ys) @ [x])) =
         set (interp_ins (xs @ (oid, Some ref) # ys)) \<union> {fst x}"
    using interp_ins_maybe_grow2 by blast
  ultimately show "oid \<notin> set (interp_ins ops)"
    using snoc.prems(2) by auto
qed

lemma interp_ins_last_None:
  shows "oid \<in> set (interp_ins (ops @ [(oid, None)]))"
by (simp add: interp_ins_tail_unfold)

lemma interp_ins_monotonic:
  assumes "insert_ops (pre @ suf)"
    and "oid \<in> set (interp_ins pre)"
  shows "oid \<in> set (interp_ins (pre @ suf))"
using assms interp_ins_maybe_grow3 by auto

lemma interp_ins_append_non_memb:
  assumes "insert_ops (pre @ [(oid, Some ref)] @ suf)"
    and "ref \<notin> set (interp_ins pre)"
  shows "ref \<notin> set (interp_ins (pre @ [(oid, Some ref)] @ suf))"
using assms proof(induction suf rule: List.rev_induct)
  case Nil
  then show "ref \<notin> set (interp_ins (pre @ [(oid, Some ref)] @ []))"
    by (metis append_Nil2 insert_spec_nonex interp_ins_tail_unfold)
next
  case (snoc x xs)
  hence IH: "ref \<notin> set (interp_ins (pre @ [(oid, Some ref)] @ xs))"
    by (metis append_assoc insert_ops_rem_last)
  moreover have "ref < oid"
    using insert_ops_ref_older snoc.prems(1) by auto
  moreover have "oid < fst x"
    using insert_ops_sorted_oids by (metis prod.collapse snoc.prems(1))
  have "set (interp_ins ((pre @ [(oid, Some ref)] @ xs) @ [x])) =
        set (interp_ins (pre @ [(oid, Some ref)] @ xs)) \<or>
        set (interp_ins ((pre @ [(oid, Some ref)] @ xs) @ [x])) =
        set (interp_ins (pre @ [(oid, Some ref)] @ xs)) \<union> {fst x}"
    by (metis (full_types) append.assoc interp_ins_maybe_grow2 snoc.prems(1))
  ultimately show "ref \<notin> set (interp_ins (pre @ [(oid, Some ref)] @ xs @ [x]))"
    using \<open>oid < fst x\<close> by auto
qed

lemma interp_ins_append_memb:
  assumes "insert_ops (pre @ [(oid, Some ref)] @ suf)"
    and "ref \<in> set (interp_ins pre)"
  shows "oid \<in> set (interp_ins (pre @ [(oid, Some ref)] @ suf))"
using assms by (metis UnCI append_assoc insert_spec_set interp_ins_monotonic
  interp_ins_tail_unfold singletonI)

lemma interp_ins_append_forward:
  assumes "insert_ops (xs @ ys)"
    and "oid \<in> set (interp_ins (xs @ ys))"
    and "oid \<in> set (map fst xs)"
  shows "oid \<in> set (interp_ins xs)"
using assms proof(induction ys rule: List.rev_induct, simp)
  case (snoc y ys)
  obtain cs ds ref where "xs = cs @ (oid, ref) # ds"
    by (metis (no_types, lifting) imageE prod.collapse set_map snoc.prems(3) split_list_last)
  hence "insert_ops (cs @ [(oid, ref)] @ (ds @ ys) @ [y])"
    using snoc.prems(1) by auto
  hence "oid < fst y"
    using insert_ops_sorted_oids by (metis prod.collapse)
  hence "oid \<noteq> fst y"
    by blast
  then show ?case
    using snoc.IH snoc.prems(1) snoc.prems(2) assms(3) inserted_item_ident
    by (metis append_assoc insert_ops_appendD interp_ins_tail_unfold prod.collapse)
qed

lemma interp_ins_find_ref:
  assumes "insert_ops (xs @ [(oid, Some ref)] @ ys)"
    and "ref \<in> set (interp_ins (xs @ [(oid, Some ref)] @ ys))"
  shows "\<exists>r. (ref, r) \<in> set xs"
proof -
  have "ref < oid"
    using assms(1) insert_ops_ref_older by blast
  have "ref \<in> set (map fst (xs @ [(oid, Some ref)] @ ys))"
    by (meson assms(2) interp_ins_subset subsetCE)
  then obtain x where x_prop: "x \<in> set (xs @ [(oid, Some ref)] @ ys) \<and> fst x = ref"
    by fastforce
  obtain xr where x_pair: "x = (ref, xr)"
    using prod.exhaust_sel x_prop by blast
  show "\<exists>r. (ref, r) \<in> set xs"
  proof(cases "x \<in> set xs")
    case True
    then show "\<exists>r. (ref, r) \<in> set xs"
      by (metis x_prop prod.collapse)
  next
    case False
    hence "(ref, xr) \<in> set ([(oid, Some ref)] @ ys)"
      using x_prop x_pair by auto
    hence "(ref, xr) \<in> set ys"
      using \<open>ref < oid\<close> x_prop
      by (metis append_Cons append_self_conv2 fst_conv min.strict_order_iff set_ConsD)
    then obtain as bs where "ys = as @ (ref, xr) # bs"
      by (meson split_list)
    hence "insert_ops ((xs @ [(oid, Some ref)] @ as @ [(ref, xr)]) @ bs)"
      using assms(1) by auto
    hence "insert_ops (xs @ [(oid, Some ref)] @ as @ [(ref, xr)])"
      using insert_ops_appendD by blast
    hence "oid < ref" (* contradiction *)
      using insert_ops_sorted_oids by auto
    then show ?thesis
      using \<open>ref < oid\<close> by force
  qed
qed

subsection\<open>Lemmas about \isa{list-order}\<close>

lemma list_order_append:
  assumes "insert_ops (pre @ suf)"
    and "list_order pre x y"
  shows "list_order (pre @ suf) x y"
by (metis Un_iff assms list_order_monotonic insert_ops_appendD set_append subset_code(1))

lemma list_order_insert_none:
  assumes "insert_ops (ops @ [(oid, None)])"
    and "x \<in> set (interp_ins ops)"
  shows "list_order (ops @ [(oid, None)]) oid x"
proof -
  have "interp_ins (ops @ [(oid, None)]) = insert_spec (interp_ins ops) (oid, None)"
    by (simp add: interp_ins_tail_unfold)
  moreover obtain xs ys where "interp_ins ops = xs @ [x] @ ys"
    using assms(2) split_list_first by fastforce
  hence "insert_spec (interp_ins ops) (oid, None) = [] @ [oid] @ xs @ [x] @ ys"
    by simp
  ultimately show "list_order (ops @ [(oid, None)]) oid x"
    using assms(1) list_orderI by metis
qed

lemma list_order_insert_between:
  assumes "insert_ops (ops @ [(oid, Some ref)])"
    and "list_order ops ref x"
  shows "list_order (ops @ [(oid, Some ref)]) oid x"
proof -
  have "interp_ins (ops @ [(oid, Some ref)]) = insert_spec (interp_ins ops) (oid, Some ref)"
    by (simp add: interp_ins_tail_unfold)
  moreover obtain xs ys zs where "interp_ins ops = xs @ [ref] @ ys @ [x] @ zs"
    using assms list_orderE by blast
  moreover have "... = xs @ ref # (ys @ [x] @ zs)"
    by simp
  moreover have "distinct (xs @ ref # (ys @ [x] @ zs))"
    using assms(1) calculation by (metis interp_ins_distinct insert_ops_rem_last)
  hence "insert_spec (xs @ ref # (ys @ [x] @ zs)) (oid, Some ref) = xs @ ref # oid # (ys @ [x] @ zs)"
    using assms(1) calculation by (simp add: insert_after_ref)
  moreover have "... = (xs @ [ref]) @ [oid] @ ys @ [x] @ zs"
    by simp
  ultimately show "list_order (ops @ [(oid, Some ref)]) oid x"
    using assms(1) list_orderI by metis
qed

subsection\<open>The \isa{insert-seq} predicate\<close>

text\<open>The predicate \isa{insert-seq start ops} is true iff \isa{ops} is a list
of insertion operations that begins by inserting after \isa{start}, and then
continues by placing each subsequent insertion directly after its predecessor.
This definition models the sequential insertion of text at a particular place
in a text document.\<close>

inductive insert_seq :: "'oid option \<Rightarrow> ('oid \<times> 'oid option) list \<Rightarrow> bool" where
  "insert_seq start [(oid, start)]" |
  "\<lbrakk>insert_seq start (list @ [(prev, ref)])\<rbrakk>
      \<Longrightarrow> insert_seq start (list @ [(prev, ref), (oid, Some prev)])"

lemma insert_seq_nonempty:
  assumes "insert_seq start xs"
  shows "xs \<noteq> []"
using assms by (induction rule: insert_seq.induct, auto)

lemma insert_seq_hd:
  assumes "insert_seq start xs"
  shows "\<exists>oid. hd xs = (oid, start)"
using assms by (induction rule: insert_seq.induct, simp,
  metis append_self_conv2 hd_append2 list.sel(1))

lemma insert_seq_rem_last:
  assumes "insert_seq start (xs @ [x])"
    and "xs \<noteq> []"
  shows "insert_seq start xs"
using assms insert_seq.cases by fastforce

lemma insert_seq_butlast:
  assumes "insert_seq start xs"
    and "xs \<noteq> []" and "xs \<noteq> [last xs]"
  shows "insert_seq start (butlast xs)"
proof -
  have "length xs > 1"
    by (metis One_nat_def Suc_lessI add_0_left append_butlast_last_id append_eq_append_conv
        append_self_conv2 assms(2) assms(3) length_greater_0_conv list.size(3) list.size(4))
  hence "butlast xs \<noteq> []"
    by (metis length_butlast less_numeral_extra(3) list.size(3) zero_less_diff)
  then show "insert_seq start (butlast xs)"
    using assms by (metis append_butlast_last_id insert_seq_rem_last)
qed

lemma insert_seq_last_ref:
  assumes "insert_seq start (xs @ [(xi, xr), (yi, yr)])"
  shows "yr = Some xi"
using assms insert_seq.cases by fastforce

lemma insert_seq_start_none:
  assumes "insert_ops ops"
    and "insert_seq None xs" and "insert_ops xs"
    and "set xs \<subseteq> set ops"
  shows "\<forall>i \<in> set (map fst xs). i \<in> set (interp_ins ops)"
using assms proof(induction xs rule: List.rev_induct, simp)
  case (snoc x xs)
  then have IH: "\<forall>i \<in> set (map fst xs). i \<in> set (interp_ins ops)"
    by (metis Nil_is_map_conv append_is_Nil_conv insert_ops_appendD insert_seq_rem_last
        le_supE list.simps(3) set_append split_list)
  then show "\<forall>i \<in> set (map fst (xs @ [x])). i \<in> set (interp_ins ops)"
  proof(cases "xs = []")
    case True
    then obtain oid where "xs @ [x] = [(oid, None)]"
      using insert_seq_hd snoc.prems(2) by fastforce
    hence "(oid, None) \<in> set ops"
      using snoc.prems(4) by auto
    then obtain as bs where "ops = as @ (oid, None) # bs"
      by (meson split_list)
    hence "ops = (as @ [(oid, None)]) @ bs"
      by (simp add: \<open>ops = as @ (oid, None) # bs\<close>)
    moreover have "oid \<in> set (interp_ins (as @ [(oid, None)]))"
      by (simp add: interp_ins_last_None)
    ultimately have "oid \<in> set (interp_ins ops)"
      using interp_ins_monotonic snoc.prems(1) by blast
    then show "\<forall>i \<in> set (map fst (xs @ [x])). i \<in> set (interp_ins ops)"
      using \<open>xs @ [x] = [(oid, None)]\<close> by auto
  next
    case False
    then obtain rest y where snoc_y: "xs = rest @ [y]"
      using append_butlast_last_id by metis
    obtain yi yr xi xr where yx_pairs: "y = (yi, yr) \<and> x = (xi, xr)"
      by force
    then have "xr = Some yi"
      using insert_seq_last_ref snoc.prems(2) snoc_y by fastforce
    have "yi < xi"
      using insert_ops_sorted_oids snoc_y yx_pairs snoc.prems(3)
      by (metis (no_types, lifting) append_eq_append_conv2)
    have "(yi, yr) \<in> set ops" and "(xi, Some yi) \<in> set ops"
      using snoc.prems(4) snoc_y yx_pairs \<open>xr = Some yi\<close> by auto
    then obtain as bs cs where ops_split: "ops = as @ [(yi, yr)] @ bs @ [(xi, Some yi)] @ cs"
      using insert_ops_split_2 \<open>yi < xi\<close> snoc.prems(1) by blast
    hence "yi \<in> set (interp_ins (as @ [(yi, yr)] @ bs))"
    proof -
      have "yi \<in> set (interp_ins ops)"
        by (simp add: IH snoc_y yx_pairs)
      moreover have "ops = (as @ [(yi, yr)] @ bs) @ ([(xi, Some yi)] @ cs)"
        using ops_split by simp
      moreover have "yi \<in> set (map fst (as @ [(yi, yr)] @ bs))"
        by simp
      ultimately show ?thesis
        using snoc.prems(1) interp_ins_append_forward by blast
    qed
    hence "xi \<in> set (interp_ins ((as @ [(yi, yr)] @ bs) @ [(xi, Some yi)] @ cs))"
      using snoc.prems(1) interp_ins_append_memb ops_split by force
    hence "xi \<in> set (interp_ins ops)"
      by (simp add: ops_split)
    then show "\<forall>i \<in> set (map fst (xs @ [x])). i \<in> set (interp_ins ops)"
      using IH yx_pairs by auto
  qed
qed

lemma insert_seq_after_start:
  assumes "insert_ops ops"
    and "insert_seq (Some ref) xs" and "insert_ops xs"
    and "set xs \<subseteq> set ops"
    and "ref \<in> set (interp_ins ops)"
  shows "\<forall>i \<in> set (map fst xs). list_order ops ref i"
using assms proof(induction xs rule: List.rev_induct, simp)
  case (snoc x xs)
  have IH: "\<forall>i \<in> set (map fst xs). list_order ops ref i"
    using snoc.IH snoc.prems insert_seq_rem_last insert_ops_appendD
    by (metis Nil_is_map_conv Un_subset_iff empty_set equals0D set_append)
  moreover have "list_order ops ref (fst x)"
  proof(cases "xs = []")
    case True
    hence "snd x = Some ref"
      using insert_seq_hd snoc.prems(2) by fastforce
    moreover have "x \<in> set ops"
      using snoc.prems(4) by auto
    then obtain cs ds where x_split: "ops = cs @ x # ds"
      by (meson split_list)
    have "list_order (cs @ [(fst x, Some ref)]) ref (fst x)"
    proof -
      have "insert_ops (cs @ [(fst x, Some ref)] @ ds)"
        using x_split \<open>snd x = Some ref\<close>
        by (metis append_Cons append_self_conv2 prod.collapse snoc.prems(1))
      moreover from this obtain rr where "(ref, rr) \<in> set cs"
        using interp_ins_find_ref x_split \<open>snd x = Some ref\<close> assms(5)
        by (metis (no_types, lifting) append_Cons append_self_conv2 prod.collapse)
      hence "ref \<in> set (interp_ins cs)"
      proof -
        have "ops = cs @ ([(fst x, Some ref)] @ ds)"
          by (metis x_split \<open>snd x = Some ref\<close> append_Cons append_self_conv2 prod.collapse)
        thus "ref \<in> set (interp_ins cs)"
          using assms(5) calculation interp_ins_append_forward interp_ins_append_non_memb by blast
      qed
      ultimately show "list_order (cs @ [(fst x, Some ref)]) ref (fst x)"
        using list_order_insert_ref by (metis append.assoc insert_ops_appendD)
    qed
    moreover have "ops = (cs @ [(fst x, Some ref)]) @ ds"
      using calculation x_split
      by (metis append_eq_Cons_conv append_eq_append_conv2 append_self_conv2 prod.collapse)
    ultimately show "list_order ops ref (fst x)"
      using list_order_append snoc.prems(1) by blast
  next
    case False
    then obtain rest y where snoc_y: "xs = rest @ [y]"
      using append_butlast_last_id by metis
    obtain yi yr xi xr where yx_pairs: "y = (yi, yr) \<and> x = (xi, xr)"
      by force
    then have "xr = Some yi"
      using insert_seq_last_ref snoc.prems(2) snoc_y by fastforce
    have "yi < xi"
      using insert_ops_sorted_oids snoc_y yx_pairs snoc.prems(3)
      by (metis (no_types, lifting) append_eq_append_conv2)
    have "(yi, yr) \<in> set ops" and "(xi, Some yi) \<in> set ops"
      using snoc.prems(4) snoc_y yx_pairs \<open>xr = Some yi\<close> by auto
    then obtain as bs cs where ops_split: "ops = as @ [(yi, yr)] @ bs @ [(xi, Some yi)] @ cs"
      using insert_ops_split_2 \<open>yi < xi\<close> snoc.prems(1) by blast
    have "list_order ops ref yi"
      by (simp add: IH snoc_y yx_pairs)
    moreover have "list_order (as @ [(yi, yr)] @ bs @ [(xi, Some yi)]) yi xi"
    proof -
      have "insert_ops ((as @ [(yi, yr)] @ bs @ [(xi, Some yi)]) @ cs)"
        using ops_split snoc.prems(1) by auto
      hence "insert_ops ((as @ [(yi, yr)] @ bs) @ [(xi, Some yi)])"
        using insert_ops_appendD by fastforce
      moreover have "yi \<in> set (interp_ins ops)"
        using \<open>list_order ops ref yi\<close> list_order_memb2 by auto
      hence "yi \<in> set (interp_ins (as @ [(yi, yr)] @ bs))"
        using interp_ins_append_non_memb ops_split snoc.prems(1) by force
      ultimately show ?thesis
        using list_order_insert_ref by force
    qed
    hence "list_order ops yi xi"
      by (metis append_assoc list_order_append ops_split snoc.prems(1))
    ultimately show "list_order ops ref (fst x)"
      using list_order_trans snoc.prems(1) yx_pairs by auto
  qed
  ultimately show "\<forall>i \<in> set (map fst (xs @ [x])). list_order ops ref i"
    by auto
qed

lemma insert_seq_no_start:
  assumes "insert_ops ops"
    and "insert_seq (Some ref) xs" and "insert_ops xs"
    and "set xs \<subseteq> set ops"
    and "ref \<notin> set (interp_ins ops)"
  shows "\<forall>i \<in> set (map fst xs). i \<notin> set (interp_ins ops)"
using assms proof(induction xs rule: List.rev_induct, simp)
  case (snoc x xs)
  have IH: "\<forall>i \<in> set (map fst xs). i \<notin> set (interp_ins ops)"
    using snoc.IH snoc.prems insert_seq_rem_last insert_ops_appendD
    by (metis append_is_Nil_conv le_sup_iff list.map_disc_iff set_append split_list_first)
  obtain as bs where "ops = as @ x # bs"
    using snoc.prems(4) by (metis split_list last_in_set snoc_eq_iff_butlast subset_code(1))
  have "fst x \<notin> set (interp_ins ops)"
  proof(cases "xs = []")
    case True
    then obtain xi where "x = (xi, Some ref)"
      using insert_seq_hd snoc.prems(2) by force
    moreover have "ref \<notin> set (interp_ins as)"
      using interp_ins_monotonic snoc.prems(1) snoc.prems(5) \<open>ops = as @ x # bs\<close> by blast
    ultimately have "xi \<notin> set (interp_ins (as @ [x] @ bs))"
      using snoc.prems(1) by (simp add: interp_ins_ref_nonex \<open>ops = as @ x # bs\<close>)
    then show "fst x \<notin> set (interp_ins ops)"
      by (simp add: \<open>ops = as @ x # bs\<close> \<open>x = (xi, Some ref)\<close>)
  next
    case xs_nonempty: False
    then obtain y where "xs = (butlast xs) @ [y]"
      by (metis append_butlast_last_id)
    moreover from this obtain yi yr xi xr where "y = (yi, yr) \<and> x = (xi, xr)"
      by fastforce
    moreover from this have "xr = Some yi"
      using insert_seq.cases snoc.prems(2) calculation by fastforce
    moreover have "yi \<notin> set (interp_ins ops)"
      using IH calculation
      by (metis Nil_is_map_conv fst_conv last_in_set last_map snoc_eq_iff_butlast)
    hence "yi \<notin> set (interp_ins as)"
      using \<open>ops = as @ x # bs\<close> interp_ins_monotonic snoc.prems(1) by blast
    ultimately have "xi \<notin> set (interp_ins (as @ [x] @ bs))"
      using interp_ins_ref_nonex snoc.prems(1) \<open>ops = as @ x # bs\<close> by fastforce
    then show "fst x \<notin> set (interp_ins ops)"
      by (simp add: \<open>ops = as @ x # bs\<close> \<open>y = (yi, yr) \<and> x = (xi, xr)\<close>)
  qed
  then show "\<forall>i \<in> set (map fst (xs @ [x])). i \<notin> set (interp_ins ops)"
    using IH by auto
qed

subsection\<open>The proof of no interleaving\<close>

lemma no_interleaving_ordered:
  assumes "insert_ops ops"
    and "insert_seq start xs" and "insert_ops xs"
    and "insert_seq start ys" and "insert_ops ys"
    and "set xs \<subseteq> set ops" and "set ys \<subseteq> set ops"
    and "distinct (map fst xs @ map fst ys)"
    and "fst (hd xs) < fst (hd ys)"
    and "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
  shows "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order ops y x) \<and>
         (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst xs). list_order ops r x) \<and>
                                 (\<forall>y \<in> set (map fst ys). list_order ops r y))"
using assms proof(induction ops arbitrary: xs ys rule: List.rev_induct, simp)
  case (snoc a ops)
  then have "insert_ops ops"
    using insert_ops_rem_last by auto
  consider (a_in_xs) "a \<in> set xs" | (a_in_ys) "a \<in> set ys" | (neither) "a \<notin> set xs \<and> a \<notin> set ys"
    by blast
  then show ?case
  proof(cases)
    case a_in_xs
    then have "a \<notin> set ys"
      using snoc.prems(8) by auto
    hence "set ys \<subseteq> set ops"
      using snoc.prems(7) DiffE by auto
    from a_in_xs have "a = last xs"
      using insert_ops_subset_last snoc.prems by blast
    have IH: "(\<forall>x \<in> set (map fst (butlast xs)). \<forall>y \<in> set (map fst ys).  list_order ops y x) \<and>
              (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst (butlast xs)). list_order ops r x) \<and>
                                      (\<forall>y \<in> set (map fst          ys).  list_order ops r y))"
    proof(cases "xs = [a]")
      case True
      moreover have "\<forall>r. start = Some r \<longrightarrow> (\<forall>y \<in> set (map fst ys). list_order ops r y)"
        using insert_seq_after_start \<open>insert_ops ops\<close> \<open>set ys \<subseteq> set ops\<close> snoc.prems
        by (metis append_Nil2 calculation insert_seq_hd interp_ins_append_non_memb list.sel(1))
      ultimately show ?thesis by auto
    next
      case xs_longer: False
      from \<open>a = last xs\<close> have "set (butlast xs) \<subseteq> set ops"
        using snoc.prems by (simp add: distinct_fst subset_butlast)
      moreover have "insert_seq start (butlast xs)"
        using insert_seq_butlast insert_seq_nonempty xs_longer \<open>a = last xs\<close> snoc.prems(2) by blast
      moreover have "insert_ops (butlast xs)"
        using snoc.prems(2) snoc.prems(3) insert_ops_appendD
        by (metis append_butlast_last_id insert_seq_nonempty)
      moreover have "distinct (map fst (butlast xs) @ map fst ys)"
        using distinct_append_butlast1 snoc.prems(8) by blast
      moreover have "set ys \<subseteq> set ops"
        using \<open>a \<notin> set ys\<close> \<open>set ys \<subseteq> set ops\<close> by blast
      moreover have "hd (butlast xs) = hd xs"
        by (metis append_butlast_last_id calculation(2) hd_append2 insert_seq_nonempty snoc.prems(2))
      hence "fst (hd (butlast xs)) < fst (hd ys)"
        by (simp add: snoc.prems(9))
      moreover have "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
      proof -
        fix r
        assume "start = Some r"
        then obtain xid where "hd xs = (xid, Some r)"
          using insert_seq_hd snoc.prems(2) by auto
        hence "r < xid"
          by (metis hd_in_set insert_ops_memb_ref_older insert_seq_nonempty snoc.prems(2) snoc.prems(3))
        moreover have "xid < fst a"
        proof -
          have "xs = (butlast xs) @ [a]"
            using snoc.prems(2) insert_seq_nonempty \<open>a = last xs\<close> by fastforce
          moreover have "(xid, Some r) \<in> set (butlast xs)"
            using \<open>hd xs = (xid, Some r)\<close> insert_seq_nonempty list.set_sel(1) snoc.prems(2)
            by (metis \<open>hd (butlast xs) = hd xs\<close> \<open>insert_seq start (butlast xs)\<close>)
          hence "xid \<in> set (map fst (butlast xs))"
            by (metis in_set_zipE zip_map_fst_snd)
          ultimately show ?thesis
            using snoc.prems(3) last_op_greatest by (metis prod.collapse)
        qed
        ultimately have "r \<noteq> fst a"
          using dual_order.asym by blast
        thus "r \<in> set (interp_ins ops)"
          using snoc.prems(1) snoc.prems(10) interp_ins_maybe_grow2 \<open>start = Some r\<close> by blast
      qed
      ultimately show ?thesis
        using \<open>insert_ops ops\<close> snoc.IH snoc.prems(4) snoc.prems(5) by blast
    qed
    moreover have x_exists: "\<forall>x \<in> set (map fst (butlast xs)). x \<in> set (interp_ins ops)"
    proof(cases start)
      case None
      moreover have "set (butlast xs) \<subseteq> set ops"
        using \<open>a = last xs\<close> distinct_map snoc.prems(6) snoc.prems(8) subset_butlast by fastforce
      ultimately show ?thesis
        using insert_seq_start_none \<open>insert_ops ops\<close> snoc.prems
        by (metis append_butlast_last_id butlast.simps(2) empty_iff empty_set
            insert_ops_rem_last insert_seq_butlast insert_seq_nonempty list.simps(8))
    next
      case (Some a)
      then show ?thesis
        using IH list_order_memb2 by blast
    qed
    moreover have "\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y (fst a)"
    proof(cases "xs = [a]")
      case xs_a: True
      have "ys \<noteq> [] \<Longrightarrow> False"
      proof -
        assume "ys \<noteq> []"
        then obtain yi where yi_def: "ys = (yi, start) # (tl ys)"
          by (metis hd_Cons_tl insert_seq_hd snoc.prems(4))
        hence "(yi, start) \<in> set ops"
          by (metis \<open>set ys \<subseteq> set ops\<close> list.set_intros(1) subsetCE)
        hence "yi \<in> set (map fst ops)"
          by force
        hence "yi < fst a"
          using snoc.prems(1) last_op_greatest by (metis prod.collapse)
        moreover have "fst a < yi"
          by (metis yi_def xs_a fst_conv list.sel(1) snoc.prems(9))
        ultimately show False
          using less_not_sym by blast
      qed
      then show "\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y (fst a)"
        using insert_seq_nonempty snoc.prems(4) by blast
    next
      case xs_longer: False
      hence butlast_split: "butlast xs = (butlast (butlast xs)) @ [last (butlast xs)]"
        using \<open>a = last xs\<close> insert_seq_butlast insert_seq_nonempty snoc.prems(2) by fastforce
      hence ref_exists: "fst (last (butlast xs)) \<in> set (interp_ins ops)"
        using x_exists by (metis last_in_set last_map map_is_Nil_conv snoc_eq_iff_butlast)
      moreover from butlast_split have "xs = (butlast (butlast xs)) @ [last (butlast xs), a]"
        by (metis \<open>a = last xs\<close> append.assoc append_butlast_last_id butlast.simps(2)
            insert_seq_nonempty last_ConsL last_ConsR list.simps(3) snoc.prems(2))
      hence "snd a = Some (fst (last (butlast xs)))"
        using snoc.prems(2) insert_seq_last_ref by (metis prod.collapse)
      hence "list_order (ops @ [a]) (fst (last (butlast xs))) (fst a)"
        using list_order_insert_ref ref_exists snoc.prems(1) by (metis prod.collapse)
      moreover have "\<forall>y \<in> set (map fst ys). list_order ops y (fst (last (butlast xs)))"
        by (metis IH butlast_split last_in_set last_map map_is_Nil_conv snoc_eq_iff_butlast)
      hence "\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y (fst (last (butlast xs)))"
        using list_order_append snoc.prems(1) by blast
      ultimately show "\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y (fst a)"
        using list_order_trans snoc.prems(1) by blast
    qed
    moreover have map_fst_xs: "map fst xs = map fst (butlast xs) @ map fst [last xs]"
      by (metis append_butlast_last_id insert_seq_nonempty map_append snoc.prems(2))
    hence "set (map fst xs) = set (map fst (butlast xs)) \<union> {fst a}"
      by (simp add: \<open>a = last xs\<close>)
    moreover have "\<forall>r. start = Some r \<longrightarrow> list_order (ops @ [a]) r (fst a)"
      using snoc.prems by (cases start, auto simp add: insert_seq_after_start \<open>a = last xs\<close> map_fst_xs)
    ultimately show "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y x) \<and>
          (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) r x) \<and>
                                  (\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) r y))"
      using snoc.prems(1) by (simp add: list_order_append)
  next
    case a_in_ys
    then have "a \<notin> set xs"
      using snoc.prems(8) by auto
    hence "set xs \<subseteq> set ops"
      using snoc.prems(6) DiffE by auto
    from a_in_ys have "a = last ys"
      using insert_ops_subset_last snoc.prems by blast
    have IH: "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst (butlast ys)).  list_order ops y x) \<and>
              (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst          xs).  list_order ops r x) \<and>
                                      (\<forall>y \<in> set (map fst (butlast ys)). list_order ops r y))"
    proof(cases "ys = [a]")
      case True
      moreover have "\<forall>r. start = Some r \<longrightarrow> (\<forall>y \<in> set (map fst xs). list_order ops r y)"
        using insert_seq_after_start \<open>insert_ops ops\<close> \<open>set xs \<subseteq> set ops\<close> snoc.prems
        by (metis append_Nil2 calculation insert_seq_hd interp_ins_append_non_memb list.sel(1))
      ultimately show ?thesis by auto
    next
      case ys_longer: False
      from \<open>a = last ys\<close> have "set (butlast ys) \<subseteq> set ops"
        using snoc.prems by (simp add: distinct_fst subset_butlast)
      moreover have "insert_seq start (butlast ys)"
        using insert_seq_butlast insert_seq_nonempty ys_longer \<open>a = last ys\<close> snoc.prems(4) by blast
      moreover have "insert_ops (butlast ys)"
        using snoc.prems(4) snoc.prems(5) insert_ops_appendD
        by (metis append_butlast_last_id insert_seq_nonempty)
      moreover have "distinct (map fst xs @ map fst (butlast ys))"
        using distinct_append_butlast2 snoc.prems(8) by blast
      moreover have "set xs \<subseteq> set ops"
        using \<open>a \<notin> set xs\<close> \<open>set xs \<subseteq> set ops\<close> by blast
      moreover have "hd (butlast ys) = hd ys"
        by (metis append_butlast_last_id calculation(2) hd_append2 insert_seq_nonempty snoc.prems(4))
      hence "fst (hd xs) < fst (hd (butlast ys))"
        by (simp add: snoc.prems(9))
      moreover have "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
      proof -
        fix r
        assume "start = Some r"
        then obtain yid where "hd ys = (yid, Some r)"
          using insert_seq_hd snoc.prems(4) by auto
        hence "r < yid"
          by (metis hd_in_set insert_ops_memb_ref_older insert_seq_nonempty snoc.prems(4) snoc.prems(5))
        moreover have "yid < fst a"
        proof -
          have "ys = (butlast ys) @ [a]"
            using snoc.prems(4) insert_seq_nonempty \<open>a = last ys\<close> by fastforce
          moreover have "(yid, Some r) \<in> set (butlast ys)"
            using \<open>hd ys = (yid, Some r)\<close> insert_seq_nonempty list.set_sel(1) snoc.prems(2)
            by (metis \<open>hd (butlast ys) = hd ys\<close> \<open>insert_seq start (butlast ys)\<close>)
          hence "yid \<in> set (map fst (butlast ys))"
            by (metis in_set_zipE zip_map_fst_snd)
          ultimately show ?thesis
            using snoc.prems(5) last_op_greatest by (metis prod.collapse)
        qed
        ultimately have "r \<noteq> fst a"
          using dual_order.asym by blast
        thus "r \<in> set (interp_ins ops)"
          using snoc.prems(1) snoc.prems(10) interp_ins_maybe_grow2 \<open>start = Some r\<close> by blast
      qed
      ultimately show ?thesis
        using \<open>insert_ops ops\<close> snoc.IH snoc.prems(2) snoc.prems(3) by blast
    qed
    moreover have "\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) (fst a) x"
    proof(cases "ys = [a]")
      case ys_a: True
      then show "\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) (fst a) x"
      proof(cases start)
        case None
        then show ?thesis
          using insert_seq_start_none list_order_insert_none snoc.prems
          by (metis \<open>insert_ops ops\<close> \<open>set xs \<subseteq> set ops\<close> fst_conv insert_seq_hd list.sel(1) ys_a)
      next
        case (Some r)
        moreover from this have "\<forall>x \<in> set (map fst xs). list_order ops r x"
          using IH by blast
        ultimately show ?thesis
          using snoc.prems(1) snoc.prems(4) list_order_insert_between
          by (metis fst_conv insert_seq_hd list.sel(1) ys_a)
      qed
    next
      case ys_longer: False
      hence butlast_split: "butlast ys = (butlast (butlast ys)) @ [last (butlast ys)]"
        using \<open>a = last ys\<close> insert_seq_butlast insert_seq_nonempty snoc.prems(4) by fastforce
      moreover from this have "ys = (butlast (butlast ys)) @ [last (butlast ys), a]"
        by (metis \<open>a = last ys\<close> append.assoc append_butlast_last_id butlast.simps(2)
            insert_seq_nonempty last_ConsL last_ConsR list.simps(3) snoc.prems(4))
      hence "snd a = Some (fst (last (butlast ys)))"
        using snoc.prems(4) insert_seq_last_ref by (metis prod.collapse)
      moreover have "\<forall>x \<in> set (map fst xs). list_order ops (fst (last (butlast ys))) x"
        by (metis IH butlast_split last_in_set last_map map_is_Nil_conv snoc_eq_iff_butlast)
      ultimately show "\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) (fst a) x"
        using list_order_insert_between snoc.prems(1) by (metis prod.collapse)
    qed
    moreover have map_fst_xs: "map fst ys = map fst (butlast ys) @ map fst [last ys]"
      by (metis append_butlast_last_id insert_seq_nonempty map_append snoc.prems(4))
    hence "set (map fst ys) = set (map fst (butlast ys)) \<union> {fst a}"
      by (simp add: \<open>a = last ys\<close>)
    moreover have "\<forall>r. start = Some r \<longrightarrow> list_order (ops @ [a]) r (fst a)"
      using snoc.prems by (cases start, auto simp add: insert_seq_after_start \<open>a = last ys\<close> map_fst_xs)
    ultimately show "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y x) \<and>
          (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) r x) \<and>
                                  (\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) r y))"
      using snoc.prems(1) by (simp add: list_order_append)
  next
    case neither
    hence "set xs \<subseteq> set ops" and "set ys \<subseteq> set ops"
      using snoc.prems(6) snoc.prems(7) DiffE by auto
    have "(\<forall>r. start = Some r \<longrightarrow> r \<in> set (interp_ins ops)) \<or> (xs = [] \<and> ys = [])"
    proof(cases xs)
      case Nil
      then show ?thesis using insert_seq_nonempty snoc.prems(2) by blast
    next
      case xs_nonempty: (Cons x xsa)
      have "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
      proof -
        fix r
        assume "start = Some r"
        then obtain xi where "x = (xi, Some r)"
          using insert_seq_hd xs_nonempty snoc.prems(2) by fastforce
        hence "(xi, Some r) \<in> set ops"
          using \<open>set xs \<subseteq> set ops\<close> xs_nonempty by auto
        hence "r < xi"
          using \<open>insert_ops ops\<close> insert_ops_memb_ref_older by blast
        moreover have "xi \<in> set (map fst ops)"
          using \<open>(xi, Some r) \<in> set ops\<close> by force
        hence "xi < fst a"
          using last_op_greatest snoc.prems(1) by (metis prod.collapse)
        ultimately have "fst a \<noteq> r"
          using order.asym by blast
        then show "r \<in> set (interp_ins ops)"
          using snoc.prems(1) snoc.prems(10) interp_ins_maybe_grow2 \<open>start = Some r\<close> by blast
      qed
      then show ?thesis by blast
    qed
    hence "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order ops y x) \<and>
           (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst xs). list_order ops r x) \<and>
                                   (\<forall>y \<in> set (map fst ys). list_order ops r y))"
      using snoc.prems snoc.IH \<open>set xs \<subseteq> set ops\<close> \<open>set ys \<subseteq> set ops\<close> by blast
    then show "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order (ops @ [a]) y x) \<and>
          (\<forall>r. start = Some r \<longrightarrow> (\<forall>x \<in> set (map fst xs). list_order (ops @ [a]) r x) \<and>
                                  (\<forall>y \<in> set (map fst ys). list_order (ops @ [a]) r y))"
      using snoc.prems(1) by (simp add: list_order_append)
  qed
qed

text\<open>Consider an execution that contains two distinct insertion sequences,
\isa{xs} and \isa{ys}, that both begin at the same initial position \isa{start}.
We prove that, provided the starting element exists, the two insertion sequences
are not interleaved. That is, in the final list order, either all insertions by
\isa{xs} appear before all insertions by \isa{ys}, or vice versa.\<close>

theorem no_interleaving:
  assumes "insert_ops ops"
    and "insert_seq start xs" and "insert_ops xs"
    and "insert_seq start ys" and "insert_ops ys"
    and "set xs \<subseteq> set ops" and "set ys \<subseteq> set ops"
    and "distinct (map fst xs @ map fst ys)"
    and "start = None \<or> (\<exists>r. start = Some r \<and> r \<in> set (interp_ins ops))"
  shows "(\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order ops x y) \<or>
         (\<forall>x \<in> set (map fst xs). \<forall>y \<in> set (map fst ys). list_order ops y x)"
proof(cases "fst (hd xs) < fst (hd ys)")
  case True
  moreover have "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
    using assms(9) by blast
  ultimately have "\<forall>x\<in>set (map fst xs). \<forall>y\<in>set (map fst ys). list_order ops y x"
    using assms no_interleaving_ordered by blast
  then show ?thesis by blast
next
  case False
  hence "fst (hd ys) < fst (hd xs)"
    using assms(2) assms(4) assms(8) insert_seq_nonempty distinct_fst_append
    by (metis (no_types, lifting) hd_in_set hd_map list.map_disc_iff map_append neqE)
  moreover have "distinct (map fst ys @ map fst xs)"
    using assms(8) distinct_append_swap by blast
  moreover have "\<And>r. start = Some r \<Longrightarrow> r \<in> set (interp_ins ops)"
    using assms(9) by blast
  ultimately have "\<forall>x\<in>set (map fst ys). \<forall>y\<in>set (map fst xs). list_order ops y x"
    using assms no_interleaving_ordered by blast
  then show ?thesis by blast
qed

text\<open>For completeness, we also prove what happens if there are two insertion
sequences, \isa{xs} and \isa{ys}, but their initial position \isa{start} does
not exist. In that case, none of the insertions in \isa{xs} or \isa{ys} take
effect.\<close>

theorem missing_start_no_insertion:
  assumes "insert_ops ops"
    and "insert_seq (Some start) xs" and "insert_ops xs"
    and "insert_seq (Some start) ys" and "insert_ops ys"
    and "set xs \<subseteq> set ops" and "set ys \<subseteq> set ops"
    and "start \<notin> set (interp_ins ops)"
  shows "\<forall>x \<in> set (map fst xs) \<union> set (map fst ys). x \<notin> set (interp_ins ops)"
using assms insert_seq_no_start by (metis UnE)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>The Option Monad\<close>

theory Option_Monad
  imports "HOL-Library.Monad_Syntax"
begin

declare Option.bind_cong [fundef_cong]

definition guard :: "bool \<Rightarrow> unit option"
  where
    "guard b = (if b then Some () else None)"

lemma guard_cong [fundef_cong]:
  "b = c \<Longrightarrow> (c \<Longrightarrow> m = n) \<Longrightarrow> guard b >> m = guard c >> n"
  by (simp add: guard_def)

lemma guard_simps:
  "guard b = Some x \<longleftrightarrow> b"
  "guard b = None \<longleftrightarrow> \<not> b"
  by (cases b) (simp_all add: guard_def)

lemma guard_elims[elim]:
  "guard b = Some x \<Longrightarrow> (b \<Longrightarrow> P) \<Longrightarrow> P"
  "guard b = None \<Longrightarrow> (\<not> b \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp_all add: guard_simps)

lemma guard_intros [intro, simp]:
  "b \<Longrightarrow> guard b = Some ()"
  "\<not> b \<Longrightarrow> guard b = None"
  by (simp_all add: guard_simps)

lemma guard_True [simp]: "guard True = Some ()" by simp
lemma guard_False [simp]: "guard False = None" by simp

lemma guard_and_to_bind: "guard (a \<and> b) = guard a \<bind> (\<lambda> _. guard b)" by (cases a; cases b; auto)

fun zip_option :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list option"
  where
    "zip_option [] [] = Some []"
  | "zip_option (x#xs) (y#ys) = do { zs \<leftarrow> zip_option xs ys; Some ((x, y) # zs) }"
  | "zip_option (x#xs) [] = None"
  | "zip_option [] (y#ys) = None"

text \<open>induction scheme for zip\<close>
lemma zip_induct [case_names Cons_Cons Nil1 Nil2]:
  assumes "\<And>x xs y ys. P xs ys \<Longrightarrow> P (x # xs) (y # ys)"
    and "\<And>ys. P [] ys"
    and "\<And>xs. P xs []"
  shows "P xs ys"
  using assms by (induction_schema) (pat_completeness, lexicographic_order)

lemma zip_option_zip_conv:
  "zip_option xs ys = Some zs \<longleftrightarrow> length ys = length xs \<and> length zs = length xs \<and> zs = zip xs ys"
proof -
  {
    assume "zip_option xs ys = Some zs"
    hence "length ys = length xs \<and> length zs = length xs \<and> zs = zip xs ys"
    proof (induct xs ys arbitrary: zs rule: zip_option.induct)
      case (2 x xs y ys)
      then obtain zs' where "zip_option xs ys = Some zs'"
        and "zs = (x, y) # zs'" by (cases "zip_option xs ys") auto
      from 2(1) [OF this(1)] and this(2) show ?case by simp
    qed simp_all
  } moreover {
    assume "length ys = length xs" and "zs = zip xs ys"
    hence "zip_option xs ys = Some zs"
      by (induct xs ys arbitrary: zs rule: zip_induct) force+
  }
  ultimately show ?thesis by blast
qed

lemma zip_option_None:
  "zip_option xs ys = None \<longleftrightarrow> length xs \<noteq> length ys"
proof -
  {
    assume "zip_option xs ys = None"
    have "length xs \<noteq> length ys"
    proof (rule ccontr)
      assume "\<not> length xs \<noteq> length ys"
      hence "length xs = length ys" by simp
      hence "zip_option xs ys = Some (zip xs ys)" by (simp add: zip_option_zip_conv)
      with \<open>zip_option xs ys = None\<close> show False by simp
    qed
  } moreover {
    assume "length xs \<noteq> length ys"
    hence "zip_option xs ys = None"
      by (induct xs ys rule: zip_option.induct) simp_all
  }
  ultimately show ?thesis by blast
qed

declare zip_option.simps [simp del]

lemma zip_option_intros [intro]:
  "\<lbrakk>length ys = length xs; length zs = length xs; zs = zip xs ys\<rbrakk>
    \<Longrightarrow> zip_option xs ys = Some zs"
  "length xs \<noteq> length ys \<Longrightarrow> zip_option xs ys = None"
  by (simp_all add: zip_option_zip_conv zip_option_None)

lemma zip_option_elims [elim]:
  "zip_option xs ys = Some zs
    \<Longrightarrow> (\<lbrakk>length ys = length xs; length zs = length xs; zs = zip xs ys\<rbrakk> \<Longrightarrow> P)
    \<Longrightarrow> P"
  "zip_option xs ys = None \<Longrightarrow> (length xs \<noteq> length ys \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp_all add: zip_option_zip_conv zip_option_None)

lemma zip_option_simps [simp]:
  "zip_option xs ys = None \<Longrightarrow> length xs = length ys \<Longrightarrow> False"
  "zip_option xs ys = None \<Longrightarrow> length xs \<noteq> length ys"
  "zip_option xs ys = Some zs \<Longrightarrow> zs = zip xs ys"
  by (simp_all add: zip_option_None zip_option_zip_conv)

fun mapM :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list option"
  where
    "mapM f [] = Some []"
  | "mapM f (x#xs) = do {
      y \<leftarrow> f x;
      ys \<leftarrow> mapM f xs;
      Some (y # ys)
    }"

lemma mapM_None:
  "mapM f xs = None \<longleftrightarrow> (\<exists>x\<in>set xs. f x = None)"
proof (induct xs)
  case (Cons x xs) thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some:
  "mapM f xs = Some ys \<Longrightarrow> ys = map (\<lambda>x. the (f x)) xs \<and> (\<forall>x\<in>set xs. f x \<noteq> None)"
proof (induct xs arbitrary: ys)
  case (Cons x xs ys)
  thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some_idx:
  assumes some: "mapM f xs = Some ys" and i: "i < length xs"
  shows "\<exists>y. f (xs ! i) = Some y \<and> ys ! i = y"
proof -
  note m = mapM_Some [OF some]
  from m[unfolded set_conv_nth] i have "f (xs ! i) \<noteq> None" by auto
  then obtain y where "f (xs ! i) = Some y" by auto
  then have "f (xs ! i) = Some y \<and> ys ! i = y" unfolding m [THEN conjunct1] using i by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma mapM_map:
  "mapM f xs = (if (\<forall>x\<in>set xs. f x \<noteq> None) then Some (map (\<lambda>x. the (f x)) xs) else None)"
proof (cases "mapM f xs")
  case None
  thus ?thesis using mapM_None by auto
next
  case (Some ys)
  with mapM_Some [OF Some] show ?thesis by auto
qed

lemma mapM_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> 'c option) \<Rightarrow> 'd option"
  assumes C: "\<And>y. mono_option (C y)"
  shows "mono_option (\<lambda>f. mapM (\<lambda>y. C y f) B)"
proof (induct B)
  case Nil
  show ?case unfolding mapM.simps
    by (rule option.const_mono)
next
  case (Cons b B)
  show ?case unfolding mapM.simps
    by (rule bind_mono [OF C bind_mono [OF Cons option.const_mono]])
qed

end


(*  Title:      HOL/MicroJava/DFA/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

chapter {* Bytecode Verifier \label{cha:bv} *}

section {* Semilattices *}

theory Semilat
imports Main "~~/src/HOL/Library/While_Combinator"
begin

type_synonym 'a ord = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl = "'a set \<times> 'a ord \<times> 'a binop"

consts
  "lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  "lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  "plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
(*<*)
notation
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)
(*>*)
notation (xsymbols)
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)
(*<*)
(* allow \<sub> instead of \<bsub>..\<esub> *)

abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"
(*>*)

defs
  lesub_def:   "x \<sqsubseteq>\<^sub>r y \<equiv> r x y"
  lesssub_def: "x \<sqsubset>\<^sub>r y \<equiv> x \<sqsubseteq>\<^sub>r y \<and> x \<noteq> y"
  plussub_def: "x \<squnion>\<^sub>f y \<equiv> f x y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord" where
  "ord r \<equiv> \<lambda>x y. (x,y) \<in> r"

definition order :: "'a ord \<Rightarrow> bool" where
  "order r \<equiv> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool" where
  "top r T \<equiv> \<forall>x. x \<sqsubseteq>\<^sub>r T"

definition acc :: "'a ord \<Rightarrow> bool" where
  "acc r \<equiv> wf {(y,x). x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool" where
  "closed A f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A"

definition semilat :: "'a sl \<Rightarrow> bool" where
  "semilat \<equiv> \<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_ub r x y u \<equiv> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_lub r x y u \<equiv> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "some_lub r x y \<equiv> SOME z. is_lub r x y z"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<equiv> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (x \<squnion>\<^sub>f y = y)"
(*<*)
apply (rule iffI)
 apply (blast intro: antisym_r lub ub2)
apply (erule subst)
apply simp
done
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (y \<squnion>\<^sub>f x = y)"
(*<*)
apply (rule iffI)
 apply (blast intro: order_antisym lub ub1)
apply (erule subst)
apply simp
done
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma extend_lub:
  "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) \<in> r \<rbrakk>
  \<Longrightarrow> EX v. is_lub (r^* ) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) \<in> r^*")
 apply (case_tac "(y,x') \<in> r^*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  "\<lbrakk> single_valued r; (x,u) \<in> r^* \<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r^* \<longrightarrow>
  (EX z. is_lub (r^* ) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
(*<*)
apply (unfold some_lub_def is_lub_def)
apply (rule someI2)
 apply assumption
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection{*An executable lub-finder*}

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop" where
"exec_lub r f x y \<equiv> while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end


chapter \<open> International System of Quantities \<close>

section \<open> Quantity Dimensions \<close>

theory ISQ_Dimensions
  imports Groups_mult Power_int Enum_extra
          HOL.Transcendental
          "HOL-Eisbach.Eisbach"
begin

subsection \<open> Preliminaries \<close>

class unitary = finite +
  assumes unitary_unit_pres: "card (UNIV::'a set) = 1"
begin

definition "unit = (undefined::'a)"

lemma UNIV_unitary: "UNIV = {a::'a}"
proof -
  have "card(UNIV :: 'a set) = 1"
    by (simp add: local.unitary_unit_pres)
  thus ?thesis
    by (metis (full_types) UNIV_I card_1_singletonE empty_iff insert_iff)
qed

lemma eq_unit: "(a::'a) = b"
  by (metis (full_types) UNIV_unitary iso_tuple_UNIV_I singletonD)

end

lemma unitary_intro: "(UNIV::'s set) = {a} \<Longrightarrow> OFCLASS('s, unitary_class)"
  apply (intro_classes, auto)
  using finite.simps apply blast
  using card_1_singleton_iff apply blast
  done

named_theorems si_def and si_eq

instantiation unit :: comm_monoid_add
begin
  definition "zero_unit = ()"
  definition "plus_unit (x::unit) (y::unit) = ()"
  instance proof qed (simp_all)
end

instantiation unit :: comm_monoid_mult
begin
  definition "one_unit = ()"
  definition "times_unit (x::unit) (y::unit) = ()"
  instance proof qed (simp_all)
end

instantiation unit :: inverse
begin
  definition "inverse_unit (x::unit) = ()"
  definition "divide_unit (x::unit) (y::unit) = ()"
  instance ..
end

instance unit :: ab_group_mult
  by (intro_classes, simp_all)

subsection \<open> Dimension Vectors \<close>

text \<open> Quantity dimensions are used to distinguish quantities of different kinds. Only quantities
  of the same kind can be compared and combined: it is a mistake to add a length to a mass, for
  example. Dimensions are often expressed in terms of seven base quantities, which can be combined
  to form derived quantities. Consequently, a dimension associates with each of the base quantities
  an integer that denotes the power to which it is raised. We use a special vector type to represent
  dimensions, and then specialise this to the seven major dimensions. \<close>

typedef ('n, 'd) dimvec = "UNIV :: ('d::enum \<Rightarrow> 'n) set"
  morphisms dim_nth dim_lambda ..

declare dim_lambda_inject [simplified, simp]
declare dim_nth_inverse [simp]
declare dim_lambda_inverse [simplified, simp]

instantiation dimvec :: (zero, enum) "one"
begin
definition one_dimvec :: "('a, 'b) dimvec" where "one_dimvec = dim_lambda (\<lambda> i. 0)"
instance ..
end

instantiation dimvec :: (plus, enum) times
begin
definition times_dimvec :: "('a, 'b) dimvec \<Rightarrow> ('a, 'b) dimvec \<Rightarrow> ('a, 'b) dimvec" where
"times_dimvec x y = dim_lambda (\<lambda> i. dim_nth x i + dim_nth y i)"
instance ..
end

instance dimvec :: (comm_monoid_add, enum) comm_monoid_mult
  by ((intro_classes; simp add: times_dimvec_def one_dimvec_def fun_eq_iff add.assoc), simp add: add.commute)

text \<open> We also define the inverse and division operations, and an abelian group, which will allow
  us to perform dimensional analysis. \<close>

instantiation dimvec :: ("{plus,uminus}", enum) inverse
begin
definition inverse_dimvec :: "('a, 'b) dimvec \<Rightarrow> ('a, 'b) dimvec" where
"inverse_dimvec x = dim_lambda (\<lambda> i. - dim_nth x i)"

definition divide_dimvec :: "('a, 'b) dimvec \<Rightarrow> ('a, 'b) dimvec \<Rightarrow> ('a, 'b) dimvec" where
[code_unfold]: "divide_dimvec x y = x * (inverse y)"

  instance ..
end

instance dimvec :: (ab_group_add, enum) ab_group_mult
  by (intro_classes, simp_all add: inverse_dimvec_def one_dimvec_def times_dimvec_def divide_dimvec_def)

subsection \<open> Code Generation \<close>

text \<open> Dimension vectors can be represented using lists, which enables code generation and thus
  efficient proof. \<close>

definition mk_dimvec :: "'n list \<Rightarrow> ('n::ring_1, 'd::enum) dimvec"
  where "mk_dimvec ds = (if (length ds = CARD('d)) then dim_lambda (\<lambda> d. ds ! enum_ind d) else 1)"

code_datatype mk_dimvec

lemma mk_dimvec_inj: "inj_on (mk_dimvec :: 'n list \<Rightarrow> ('n::ring_1, 'd::enum) dimvec) {xs. length xs = CARD('d)}"
proof (rule inj_onI, safe)
  fix x y :: "'n list"
  assume a: "(mk_dimvec x :: ('n, 'd) dimvec) = mk_dimvec y" "length x = CARD('d)" "length y = CARD('d)"
  have "\<And>i. i < length x \<Longrightarrow> x ! i = y ! i"
  proof -
    fix i
    assume "i < length x"
    with a have "enum_ind (ENUM('d) ! i) = i"
      by (simp)
    with a show "x ! i = y ! i"
      by (auto simp add: mk_dimvec_def fun_eq_iff, metis)
  qed

  then show "x = y"
    by (metis a(2) a(3) nth_equalityI)
qed

lemma mk_dimvec_eq_iff [simp]:
  assumes "length x = CARD('d)" "length y = CARD('d)"
  shows "((mk_dimvec x :: ('n::ring_1, 'd::enum) dimvec) = mk_dimvec y) \<longleftrightarrow> (x = y)"
  by (rule inj_on_eq_iff[OF mk_dimvec_inj], simp_all add: assms)

lemma one_mk_dimvec [code, si_def]: "(1::('n::ring_1, 'a::enum) dimvec) = mk_dimvec (replicate CARD('a) 0)"
  by (auto simp add: mk_dimvec_def one_dimvec_def)

lemma times_mk_dimvec [code, si_def]:
  "(mk_dimvec xs * mk_dimvec ys :: ('n::ring_1, 'a::enum) dimvec) =
  (if (length xs = CARD('a) \<and> length ys = CARD('a))
    then mk_dimvec (map (\<lambda> (x, y). x + y) (zip xs ys))
    else if length xs = CARD('a) then mk_dimvec xs else mk_dimvec ys)"
  by (auto simp add: times_dimvec_def mk_dimvec_def fun_eq_iff one_dimvec_def)

lemma power_mk_dimvec [si_def]:
  "(power (mk_dimvec xs) n :: ('n::ring_1, 'a::enum) dimvec) =
    (if (length xs = CARD('a)) then mk_dimvec (map ((*) (of_nat n)) xs) else mk_dimvec xs)"
  by (induct n, simp add: one_dimvec_def mk_dimvec_def)
     (auto simp add: times_mk_dimvec zip_map_map[where f="id", simplified] comp_def split_beta' zip_same_conv_map distrib_right mult.commute)

lemma inverse_mk_dimvec [code, si_def]:
  "(inverse (mk_dimvec xs) :: ('n::ring_1, 'a::enum) dimvec) =
   (if (length xs = CARD('a)) then mk_dimvec (map uminus xs) else 1)"
  by (auto simp add: inverse_dimvec_def one_dimvec_def mk_dimvec_def fun_eq_iff)

lemma divide_mk_dimvec [code, si_def]:
  "(mk_dimvec xs / mk_dimvec ys :: ('n::ring_1, 'a::enum) dimvec) =
  (if (length xs = CARD('a) \<and> length ys = CARD('a))
    then mk_dimvec (map (\<lambda> (x, y). x - y) (zip xs ys))
    else if length ys = CARD('a) then mk_dimvec (map uminus ys) else mk_dimvec xs)"
  by (auto simp add: divide_dimvec_def inverse_mk_dimvec times_mk_dimvec zip_map_map[where f="id", simplified] comp_def split_beta')

text \<open> A base dimension is a dimension where precisely one component has power 1: it is the
  dimension of a base quantity. Here we define the seven base dimensions. \<close>

definition mk_BaseDim :: "'d::enum \<Rightarrow> (int, 'd) dimvec" where
"mk_BaseDim d = dim_lambda (\<lambda> i. if (i = d) then 1 else 0)"

lemma mk_BaseDim_neq [simp]: "x \<noteq> y \<Longrightarrow> mk_BaseDim x \<noteq> mk_BaseDim y"
  by (auto simp add: mk_BaseDim_def fun_eq_iff)

lemma mk_BaseDim_code [code]: "mk_BaseDim (d::'d::enum) = mk_dimvec (list_update (replicate CARD('d) 0) (enum_ind d) 1)"
  by (auto simp add: mk_BaseDim_def mk_dimvec_def fun_eq_iff)

definition is_BaseDim :: "(int, 'd::enum) dimvec \<Rightarrow> bool"
  where "is_BaseDim x \<equiv> (\<exists> i. x = dim_lambda ((\<lambda> x. 0)(i := 1)))"

lemma is_BaseDim_mk [simp]: "is_BaseDim (mk_BaseDim x)"
  by (auto simp add: mk_BaseDim_def is_BaseDim_def fun_eq_iff)

subsection \<open> Dimension Semantic Domain \<close>

text \<open> We next specialise dimension vectors to the usual seven place vector. \<close>

datatype sdim = Length | Mass | Time | Current | Temperature | Amount | Intensity

lemma sdim_UNIV: "(UNIV :: sdim set) = {Length, Mass, Time, Current, Temperature, Amount, Intensity}"
  using sdim.exhaust by blast

lemma CARD_sdim [simp]: "CARD(sdim) = 7"
  by (simp add: sdim_UNIV)

instantiation sdim :: enum
begin
  definition "enum_sdim = [Length, Mass, Time, Current, Temperature, Amount, Intensity]"
  definition "enum_all_sdim P \<longleftrightarrow> P Length \<and> P Mass \<and> P Time \<and> P Current \<and> P Temperature \<and> P Amount \<and> P Intensity"
  definition "enum_ex_sdim P \<longleftrightarrow> P Length \<or> P Mass \<or> P Time \<or> P Current \<or> P Temperature \<or> P Amount \<or> P Intensity"
  instance
    by (intro_classes, simp_all add: sdim_UNIV enum_sdim_def enum_all_sdim_def enum_ex_sdim_def)
end

instantiation sdim :: card_UNIV
begin
  definition "finite_UNIV = Phantom(sdim) True"
  definition "card_UNIV = Phantom(sdim) 7"
  instance by (intro_classes, simp_all add: finite_UNIV_sdim_def card_UNIV_sdim_def)
end

lemma sdim_enum [simp]:
  "enum_ind Length = 0" "enum_ind Mass = 1" "enum_ind Time = 2" "enum_ind Current = 3"
  "enum_ind Temperature = 4" "enum_ind Amount = 5" "enum_ind Intensity = 6"
  by (simp_all add: enum_ind_def enum_sdim_def)

type_synonym Dimension = "(int, sdim) dimvec"

abbreviation LengthBD      ("\<^bold>L") where "\<^bold>L \<equiv> mk_BaseDim Length"
abbreviation MassBD        ("\<^bold>M") where "\<^bold>M \<equiv> mk_BaseDim Mass"
abbreviation TimeBD        ("\<^bold>T") where "\<^bold>T \<equiv> mk_BaseDim Time"
abbreviation CurrentBD     ("\<^bold>I") where "\<^bold>I \<equiv> mk_BaseDim Current"
abbreviation TemperatureBD ("\<^bold>\<Theta>") where "\<^bold>\<Theta> \<equiv> mk_BaseDim Temperature"
abbreviation AmountBD      ("\<^bold>N") where "\<^bold>N \<equiv> mk_BaseDim Amount"
abbreviation IntensityBD   ("\<^bold>J") where "\<^bold>J \<equiv> mk_BaseDim Intensity"

abbreviation "BaseDimensions \<equiv> {\<^bold>L, \<^bold>M, \<^bold>T, \<^bold>I, \<^bold>\<Theta>, \<^bold>N, \<^bold>J}"

lemma BD_mk_dimvec [si_def]:
  "\<^bold>L = mk_dimvec [1, 0, 0, 0, 0, 0, 0]"
  "\<^bold>M = mk_dimvec [0, 1, 0, 0, 0, 0, 0]"
  "\<^bold>T = mk_dimvec [0, 0, 1, 0, 0, 0, 0]"
  "\<^bold>I = mk_dimvec [0, 0, 0, 1, 0, 0, 0]"
  "\<^bold>\<Theta> = mk_dimvec [0, 0, 0, 0, 1, 0, 0]"
  "\<^bold>N = mk_dimvec [0, 0, 0, 0, 0, 1, 0]"
  "\<^bold>J = mk_dimvec [0, 0, 0, 0, 0, 0, 1]"
  by (simp_all add: mk_BaseDim_code eval_nat_numeral)

text \<open> The following lemma confirms that there are indeed seven unique base dimensions. \<close>

lemma seven_BaseDimensions: "card BaseDimensions = 7"
  by simp

text \<open> We can use the base dimensions and algebra to form dimension expressions. Some examples
  are shown below. \<close>

term "\<^bold>L\<cdot>\<^bold>M\<cdot>\<^bold>T\<^sup>-\<^sup>2"
term "\<^bold>M\<cdot>\<^bold>L\<^sup>-\<^sup>3"

value "\<^bold>L\<cdot>\<^bold>M\<cdot>\<^bold>T\<^sup>-\<^sup>2"

lemma "\<^bold>L\<cdot>\<^bold>M\<cdot>\<^bold>T\<^sup>-\<^sup>2 = mk_dimvec [1, 1, - 2, 0, 0, 0, 0]"
  by (simp add: si_def)

subsection \<open> Dimension Type Expressions \<close>

subsubsection \<open> Classification \<close>

text \<open> We provide a syntax for dimension type expressions, which allows representation of
  dimensions as types in Isabelle. This will allow us to represent quantities that are parametrised
  by a particular dimension type. We first must characterise the subclass of types that represent a
  dimension.

  The mechanism in Isabelle to characterize a certain subclass of Isabelle type expressions
  are \<^emph>\<open>type classes\<close>. The following type class is used to link particular Isabelle types
  to an instance of the type \<^typ>\<open>Dimension\<close>. It requires that any such type has the cardinality
  \<^term>\<open>1\<close>, since a dimension type is used only to mark a quantity.
  \<close>

class dim_type = unitary +
  fixes   dim_ty_sem :: "'a itself \<Rightarrow> Dimension"

syntax
  "_QD" :: "type \<Rightarrow> logic" ("QD'(_')")

translations
  "QD('a)" == "CONST dim_ty_sem TYPE('a)"

text \<open> The notation \<^term>\<open>QD('a::dim_type)\<close> allows to obtain the dimension of a dimension type
  \<^typ>\<open>'a\<close>.

  The subset of basic dimension types can be characterized by the following type class: \<close>

class basedim_type = dim_type +
  assumes is_BaseDim: "is_BaseDim QD('a)"

subsubsection \<open> Base Dimension Type Expressions \<close>

text \<open> The definition of the basic dimension type constructors is straightforward via a
  one-elementary set, \<^typ>\<open>unit set\<close>. The latter is adequate since we need just an abstract syntax
  for type expressions, so just one value for the \<^verbatim>\<open>dimension\<close>-type symbols. We define types for
  each of the seven base dimensions, and also for dimensionless quantities. \<close>

typedef Length      = "UNIV :: unit set" .. setup_lifting type_definition_Length
typedef Mass        = "UNIV :: unit set" .. setup_lifting type_definition_Mass
typedef Time        = "UNIV :: unit set" .. setup_lifting type_definition_Time
typedef Current     = "UNIV :: unit set" .. setup_lifting type_definition_Current
typedef Temperature = "UNIV :: unit set" .. setup_lifting type_definition_Temperature
typedef Amount      = "UNIV :: unit set" .. setup_lifting type_definition_Amount
typedef Intensity   = "UNIV :: unit set" .. setup_lifting type_definition_Intensity
typedef NoDimension = "UNIV :: unit set" .. setup_lifting type_definition_NoDimension

type_synonym M = Mass
type_synonym L = Length
type_synonym T = Time
type_synonym I = Current
type_synonym \<Theta> = Temperature
type_synonym N = Amount
type_synonym J = Intensity
type_notation NoDimension ("\<one>")

translations
  (type) "M" <= (type) "Mass"
  (type) "L" <= (type) "Length"
  (type) "T" <= (type) "Time"
  (type) "I" <= (type) "Current"
  (type) "\<Theta>" <= (type) "Temperature"
  (type) "N" <= (type) "Amount"
  (type) "J" <= (type) "Intensity"

text\<open> Next, we embed the base dimensions into the dimension type expressions by instantiating the
  class \<^class>\<open>basedim_type\<close> with each of the base dimension types. \<close>

instantiation Length :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Length (_::Length itself) = \<^bold>L"
instance by (intro_classes, auto simp add: dim_ty_sem_Length_def, (transfer, simp)+)
end

instantiation Mass :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Mass (_::Mass itself) = \<^bold>M"
instance by (intro_classes, auto simp add: dim_ty_sem_Mass_def, (transfer, simp)+)
end

instantiation Time :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Time (_::Time itself) = \<^bold>T"
instance by (intro_classes, auto simp add: dim_ty_sem_Time_def, (transfer, simp)+)
end

instantiation Current :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Current (_::Current itself) = \<^bold>I"
instance by (intro_classes, auto simp add: dim_ty_sem_Current_def, (transfer, simp)+)
end

instantiation Temperature :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Temperature (_::Temperature itself) = \<^bold>\<Theta>"
instance by (intro_classes, auto simp add: dim_ty_sem_Temperature_def, (transfer, simp)+)
end

instantiation Amount :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Amount (_::Amount itself) = \<^bold>N"
instance by (intro_classes, auto simp add: dim_ty_sem_Amount_def, (transfer, simp)+)
end

instantiation Intensity :: basedim_type
begin
definition [si_eq]: "dim_ty_sem_Intensity (_::Intensity itself) = \<^bold>J"
instance by (intro_classes, auto simp add: dim_ty_sem_Intensity_def, (transfer, simp)+)
end

instantiation NoDimension :: dim_type
begin
definition [si_eq]: "dim_ty_sem_NoDimension (_::NoDimension itself) = (1::Dimension)"
instance by (intro_classes, auto simp add: dim_ty_sem_NoDimension_def, (transfer, simp)+)
end

lemma base_dimension_types [simp]:
  "is_BaseDim QD(Length)" "is_BaseDim QD(Mass)" "is_BaseDim QD(Time)" "is_BaseDim QD(Current)"
  "is_BaseDim QD(Temperature)" "is_BaseDim QD(Amount)" "is_BaseDim QD(Intensity)"
  by (simp_all add: is_BaseDim)

subsubsection \<open> Dimension Type Constructors: Inner Product and Inverse \<close>

text\<open> Dimension type expressions can be constructed by multiplication and division of the base
  dimension types above. Consequently, we need to define multiplication and inverse operators
  at the type level as well. On the class of dimension types (in which we have already inserted
  the base dimension types), the definitions of the type constructors for inner product and inverse is
  straightforward. \<close>

typedef ('a::dim_type, 'b::dim_type) DimTimes (infixl "\<cdot>" 69) = "UNIV :: unit set" ..
setup_lifting type_definition_DimTimes

text \<open> The type \<^typ>\<open>('a,'b) DimTimes\<close> is parameterised by two types, \<^typ>\<open>'a\<close> and \<^typ>\<open>'b\<close> that must
  both be elements of the \<^class>\<open>dim_type\<close> class. As with the base dimensions, it is a unitary type
  as its purpose is to represent dimension type expressions. We instantiate \<^class>\<open>dim_type\<close> with
  this type, where the semantics of a product dimension expression is the product of the underlying
  dimensions. This means that multiplication of two dimension types yields a dimension type. \<close>

instantiation DimTimes :: (dim_type, dim_type) dim_type
begin
  definition dim_ty_sem_DimTimes :: "('a \<cdot> 'b) itself \<Rightarrow> Dimension" where
  [si_eq]: "dim_ty_sem_DimTimes x = QD('a) * QD('b)"
  instance by (intro_classes, simp_all add: dim_ty_sem_DimTimes_def, (transfer, simp)+)
end

text \<open> Similarly, we define inversion of dimension types and prove that dimension types are
  closed under this. \<close>

typedef 'a DimInv ("(_\<^sup>-\<^sup>1)" [999] 999) = "UNIV :: unit set" ..
setup_lifting type_definition_DimInv
instantiation DimInv :: (dim_type) dim_type
begin
  definition dim_ty_sem_DimInv :: "('a\<^sup>-\<^sup>1) itself \<Rightarrow> Dimension" where
  [si_eq]: "dim_ty_sem_DimInv x = inverse QD('a)"
  instance by (intro_classes, simp_all add: dim_ty_sem_DimInv_def, (transfer, simp)+)
end

subsubsection \<open> Dimension Type Syntax \<close>

text \<open> A division is expressed, as usual, by multiplication with an inverted dimension. \<close>

type_synonym ('a, 'b) DimDiv = "'a \<cdot> ('b\<^sup>-\<^sup>1)" (infixl "'/" 69)

text \<open> A number of further type synonyms allow for more compact notation: \<close>

type_synonym 'a DimSquare = "'a \<cdot> 'a" ("(_)\<^sup>2" [999] 999)
type_synonym 'a DimCube = "'a \<cdot> 'a \<cdot> 'a" ("(_)\<^sup>3" [999] 999)
type_synonym 'a DimQuart = "'a \<cdot> 'a \<cdot> 'a \<cdot> 'a" ("(_)\<^sup>4" [999] 999)
type_synonym 'a DimInvSquare = "('a\<^sup>2)\<^sup>-\<^sup>1" ("(_)\<^sup>-\<^sup>2" [999] 999)
type_synonym 'a DimInvCube = "('a\<^sup>3)\<^sup>-\<^sup>1" ("(_)\<^sup>-\<^sup>3" [999] 999)
type_synonym 'a DimInvQuart = "('a\<^sup>4)\<^sup>-\<^sup>1" ("(_)\<^sup>-\<^sup>4" [999] 999)

translations (type) "'a\<^sup>-\<^sup>2" <= (type) "('a\<^sup>2)\<^sup>-\<^sup>1"
translations (type) "'a\<^sup>-\<^sup>3" <= (type) "('a\<^sup>3)\<^sup>-\<^sup>1"
translations (type) "'a\<^sup>-\<^sup>4" <= (type) "('a\<^sup>4)\<^sup>-\<^sup>1"

print_translation \<open>
  [(@{type_syntax DimTimes},
    fn ctx => fn [a, b] =>
      if (a = b)
          then Const (@{type_syntax DimSquare}, dummyT) $ a
          else case a of
            Const (@{type_syntax DimTimes}, _) $ a1 $ a2 =>
              if (a1 = a2 andalso a2 = b)
                then Const (@{type_syntax DimCube}, dummyT) $ a1
                else case a1 of
                  Const (@{type_syntax DimTimes}, _) $ a11 $ a12 =>
                    if (a11 = a12 andalso a12 = a2 andalso a2 = b)
                      then Const (@{type_syntax DimQuart}, dummyT) $ a11
                      else raise Match |
            _ => raise Match)]
\<close>

subsubsection \<open> Derived Dimension Types \<close>

type_synonym Area = "L\<^sup>2"
type_synonym Volume = "L\<^sup>3"
type_synonym Acceleration = "L\<cdot>T\<^sup>-\<^sup>1"
type_synonym Frequency = "T\<^sup>-\<^sup>1"
type_synonym Energy = "L\<^sup>2\<cdot>M\<cdot>T\<^sup>-\<^sup>2"
type_synonym Power = "L\<^sup>2\<cdot>M\<cdot>T\<^sup>-\<^sup>3"
type_synonym Force = "L\<cdot>M\<cdot>T\<^sup>-\<^sup>2"
type_synonym Pressure = "L\<^sup>-\<^sup>1\<cdot>M\<cdot>T\<^sup>-\<^sup>2"
type_synonym Charge = "I\<cdot>T"
type_synonym PotentialDifference = "L\<^sup>2\<cdot>M\<cdot>T\<^sup>-\<^sup>3\<cdot>I\<^sup>-\<^sup>1"
type_synonym Capacitance = "L\<^sup>-\<^sup>2\<cdot>M\<^sup>-\<^sup>1\<cdot>T\<^sup>4\<cdot>I\<^sup>2"

subsection \<open> ML Functions \<close>

text \<open> We define ML functions for converting a dimension to an integer vector, and vice-versa.
  These are useful for normalising dimension types. \<close>

ML \<open>
signature DIMENSION_TYPE =
sig
  val dim_to_typ: int list -> typ
  val typ_to_dim: typ -> int list
  val normalise: typ -> typ
end

structure Dimension_Type : DIMENSION_TYPE =
struct

  val dims = [@{typ L}, @{typ M}, @{typ T}, @{typ I}, @{typ \<Theta>}, @{typ N}, @{typ J}];

  fun typ_to_dim (Type (@{type_name Length}, [])) = [1, 0, 0, 0, 0, 0, 0] |
      typ_to_dim (Type (@{type_name Mass}, []))   = [0, 1, 0, 0, 0, 0, 0] |
      typ_to_dim (Type (@{type_name Time}, []))   = [0, 0, 1, 0, 0, 0, 0] |
      typ_to_dim (Type (@{type_name Current}, []))   = [0, 0, 0, 1, 0, 0, 0] |
      typ_to_dim (Type (@{type_name Temperature}, []))   = [0, 0, 0, 0, 1, 0, 0] |
      typ_to_dim (Type (@{type_name Amount}, []))   = [0, 0, 0, 0, 0, 1, 0] |
      typ_to_dim (Type (@{type_name Intensity}, []))   = [0, 0, 0, 0, 0, 0, 1] |
      typ_to_dim (Type (@{type_name NoDimension}, []))   = [0, 0, 0, 0, 0, 0, 0] |
      typ_to_dim (Type (@{type_name DimInv}, [x])) = map (fn x => 0 - x) (typ_to_dim x) |
      typ_to_dim (Type (@{type_name DimTimes}, [x, y]))
         = map (fn (x, y) => x + y) (ListPair.zip (typ_to_dim x, typ_to_dim y)) |
      typ_to_dim _ = raise Match;

  fun DimPow 0 _ = Type (@{type_name NoDimension}, []) |
      DimPow 1 t = t |
      DimPow n t = (if (n > 0) then Type (@{type_name DimTimes}, [DimPow (n - 1) t, t])
                               else Type (@{type_name DimInv}, [DimPow (0 - n) t]));

  fun dim_to_typ ds =
    let val dts = map (fn (n, d) => DimPow n d) (filter (fn (n, _) => n <> 0) (ListPair.zip (ds, dims)))
    in if (dts = []) then @{typ NoDimension} else
          foldl1 (fn (x, y) => Type (@{type_name DimTimes}, [x, y])) dts
    end;

  val normalise = dim_to_typ o typ_to_dim;

end;

Dimension_Type.typ_to_dim @{typ "L\<^sup>-\<^sup>2\<cdot>M\<^sup>-\<^sup>1\<cdot>T\<^sup>4\<cdot>I\<^sup>2\<cdot>M"};
Dimension_Type.normalise @{typ "L\<^sup>-\<^sup>2\<cdot>M\<^sup>-\<^sup>1\<cdot>T\<^sup>4\<cdot>I\<^sup>2\<cdot>M"};
\<close>

end