theory LDL imports
  "HOL-Library.Confluent_Quotient"
begin

datatype 'a rexp = Atom 'a | Alt "'a rexp" "'a rexp" | Conc "'a rexp" "'a rexp" | Star "'a rexp"

inductive ACI (infix "~" 64) where
  a1: "Alt (Alt r s) t ~ Alt r (Alt s t)"
| a2: "Alt r (Alt s t) ~ Alt (Alt r s) t"
| c: "Alt r s ~ Alt s r"
| i: "r ~ Alt r r"
| R: "r ~ r"
| A: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Alt r s ~ Alt r' s'"
| C: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Conc r s ~ Conc r' s'"
| S: "r ~ r' \<Longrightarrow> Star r ~ Star r'"

declare ACI.intros[intro]

abbreviation ACIcl (infix "~~" 64) where "(~~) \<equiv> equivclp (~)"

lemma eq_set_preserves_inter:
  fixes eq set
  assumes "\<And>r s. eq r s \<Longrightarrow> set r = set s" and "Ss \<noteq> {}"
  shows "(\<Inter>As\<in>Ss. {(x, x'). eq x x'} `` {x. set x \<subseteq> As}) \<subseteq> {(x, x'). eq x x'} `` {x. set x \<subseteq> \<Inter> Ss}"
  using assms by (auto simp: subset_eq) metis

lemma ACI_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~ s"
  shows "map_rexp f r ~ map_rexp f s"
  using assms by (induct r s rule: ACI.induct) auto

lemma ACIcl_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~~ s"
  shows "map_rexp f r ~~ map_rexp f s"
  using assms by (induct rule: equivclp_induct) (auto intro: ACI_map_respects equivclp_trans)

lemma ACI_set_eq:
  fixes r s :: "'a rexp"
  assumes "r ~ s"
  shows "set_rexp r = set_rexp s"
  using assms by (induct r s rule: ACI.induct) auto

lemma ACIcl_set_eq:
  fixes r s :: "'a rexp"
  assumes "r ~~ s"
  shows "set_rexp r = set_rexp s"
  using assms by (induct rule: equivclp_induct) (auto dest: ACI_set_eq)

lemma Alt_eq_map_rexp_iff:
  "Alt r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Alt r s \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma Conc_eq_map_rexp_iff:
  "Conc r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Conc r s \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma Star_eq_map_rexp_iff:
  "Star r = map_rexp f x \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  "map_rexp f x = Star r \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  by (cases x; auto)+

lemma AA: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Alt r s ~~ Alt r' s'"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

lemma AAA: "(~)\<^sup>*\<^sup>* r  r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Alt r s) (Alt r' s')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by (induct s s' rule: rtranclp.induct)
      (auto elim!: rtranclp.rtrancl_into_rtrancl)
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma CC: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Conc r s ~~ Conc r' s'"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

lemma CCC: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Conc r s) (Conc r' s')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by (induct s s' rule: rtranclp.induct)
      (auto elim!: rtranclp.rtrancl_into_rtrancl)
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma SS: "r ~~ r' \<Longrightarrow> Star r ~~ Star r'"
proof (induct rule: equivclp_induct)
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed auto

lemma SSS: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Star r) (Star r')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed auto

lemma map_rexp_ACI_inv: "map_rexp f x ~ y \<Longrightarrow> \<exists>z. x ~~ z \<and> y = map_rexp f z"
proof (induct "map_rexp f x" y arbitrary: x rule: ACI.induct)
  case (a1 r s t)
  then obtain r' s' t' where "x = Alt (Alt r' s') t'"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt r' (Alt s' t')"]) auto
next
  case (a2 r s t)
  then obtain r' s' t' where "x = Alt r' (Alt s' t')"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt (Alt r' s') t'"]) auto
next
  case (c r s)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt s' r'"]) auto
next
  case (i r)
  then show ?case
    by (intro exI[of _ "Alt r r"]) auto
next
  case (R r)
  then show ?case by (auto intro: exI[of _ r])
next
  case (A r rr s ss)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  moreover from A(2)[OF this(2)[symmetric]] A(4)[OF this(3)[symmetric]] obtain rr' ss' where
    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
    by blast
  ultimately show ?case using A(1,3)
    by (intro exI[of _ "Alt rr' ss'"]) (auto intro!: AA)
next
  case (C r rr s ss)
  then obtain r' s' where "x = Conc r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Conc_eq_map_rexp_iff)
  moreover from C(2)[OF this(2)[symmetric]] C(4)[OF this(3)[symmetric]] obtain rr' ss' where
    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
    by blast
  ultimately show ?case using C(1,3)
    by (intro exI[of _ "Conc rr' ss'"]) (auto intro!: CC)
next
  case (S r rr)
  then obtain r' where "x = Star r'" "map_rexp f r' = r"
    by (auto simp: Star_eq_map_rexp_iff)
  moreover from S(2)[OF this(2)[symmetric]] obtain rr' where "r' ~~ rr'" "rr = map_rexp f rr'"
    by blast
  ultimately show ?case
    by (intro exI[of _ "Star rr'"]) (auto intro!: SS)
qed

lemma reflclp_ACI: "(~)\<^sup>=\<^sup>= = (~)"
  unfolding fun_eq_iff
  by auto

lemma strong_confluentp_ACI: "strong_confluentp (~)"
  apply (rule strong_confluentpI, unfold reflclp_ACI)
  subgoal for x y z
  proof (induct x y arbitrary: z rule: ACI.induct)
    case (a1 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (a2 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (c r s)
    then show ?case
      by (cases rule: ACI.cases) (auto intro: AAA)
  next
    case (i r)
    then show ?case
      by (auto intro: AAA)
  next
    case (R r)
    then show ?case
      by auto
  next
    note A1 = ACI.A[OF _ R]
    note A2 = ACI.A[OF R]
    case (A r r' s s')
    from A(5,1-4) show ?case
    proof (cases rule: ACI.cases)
      case inner: (a1 r'' s'')
      from A(1,3) show ?thesis
        unfolding inner
      proof (elim ACI.cases[of _ r'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
        case (Xa1 rr ss tt)
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 a2 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (Xa2 r s t)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XC r s)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 c A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XI r)
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF i ACI.A[OF i]]], rotated])
          apply hypsubst
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply blast
          done
      qed auto
    next
      case inner: (a2 s'' t'')
      with A(1,3) show ?thesis
        unfolding inner
      proof (elim ACI.cases[of _ s'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
        case (Xa1 rr ss tt)
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (Xa2 r s t)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a1 a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XC r s)
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 c A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case (XI r)
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF ACI.A[OF _ i] i]], rotated])
          apply hypsubst
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply blast
          done
      qed auto
    qed (auto 5 0 intro: AAA)
  next
    case (C r r' s s')
    from C(5,1-4) show ?case
      by (cases rule: ACI.cases) (auto 5 0 intro: CCC)
  next
    case (S r r')
    from S(3,1,2) show ?case
      by (cases rule: ACI.cases) (auto intro: SSS)
  qed
  done

lemma confluent_quotient_ACI:
  "confluent_quotient (~) (~~) (~~) (~~) (~~) (~~)
     (map_rexp fst) (map_rexp snd) (map_rexp fst) (map_rexp snd)
     rel_rexp rel_rexp rel_rexp set_rexp set_rexp"
  by unfold_locales (auto dest: ACIcl_set_eq simp: rexp.in_rel rexp.rel_compp map_rexp_ACI_inv
      intro: equivpI reflpI sympI transpI ACIcl_map_respects
      strong_confluentp_imp_confluentp[OF strong_confluentp_ACI])

inductive ACIEQ (infix "\<approx>" 64) where
  a: "Alt (Alt r s) t \<approx> Alt r (Alt s t)"
| c: "Alt r s \<approx> Alt s r"
| i: "Alt r r \<approx> r"
| A: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Alt r s \<approx> Alt r' s'"
| C: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Conc r s \<approx> Conc r' s'"
| S: "r \<approx> r' \<Longrightarrow> Star r \<approx> Star r'"
| r: "r \<approx> r"
| s: "r \<approx> s \<Longrightarrow> s \<approx> r"
| t: "r \<approx> s \<Longrightarrow> s \<approx> t \<Longrightarrow> r \<approx> t"

lemma ACIEQ_le_ACIcl: "r \<approx> s \<Longrightarrow> r ~~ s"
  by (induct r s rule: ACIEQ.induct) (auto intro: AA CC SS equivclp_sym equivclp_trans)

lemma ACI_le_ACIEQ: "r ~ s \<Longrightarrow> r \<approx> s"
  by (induct r s rule: ACI.induct) (auto intro: ACIEQ.intros)

lemma ACIcl_le_ACIEQ: "r ~~ s \<Longrightarrow> r \<approx> s"
  by (induct rule: equivclp_induct) (auto 0 3 intro: ACIEQ.intros ACI_le_ACIEQ)

lemma ACIEQ_alt: "(\<approx>) = (~~)"
  by (simp add: ACIEQ_le_ACIcl ACIcl_le_ACIEQ antisym predicate2I)

quotient_type 'a ACI_rexp = "'a rexp" / "(\<approx>)"
  unfolding ACIEQ_alt by (auto intro!: equivpI reflpI sympI transpI)

lift_bnf 'a ACI_rexp
  unfolding ACIEQ_alt
  subgoal for A Q by (rule confluent_quotient.subdistributivity[OF confluent_quotient_ACI])
  subgoal for Ss by (intro eq_set_preserves_inter[rotated] ACIcl_set_eq; auto)
  done

datatype ldl = Prop string | And ldl ldl | Not ldl | Match "ldl ACI_rexp"

end


theory Examples
imports "../Sep_Log_Frag"
begin

section \<open>Examples\<close>
text \<open>In this section, some example entailments are either proven or disproven by usage of
      the decision procedures rules.\<close>

subsection \<open>Auxiliary lemmata:\<close>
lemma spatial_commut_entail: "\<Pi>\<bar>(s1*s2*\<Sigma>) \<turnstile> consequent \<Longrightarrow> \<Pi>\<bar>(s2*s1*\<Sigma>) \<turnstile> consequent"
using entails_def spatial_commut_form by force
lemma pure_commut_entail: "(p1\<and>\<^sub>pp2\<and>\<^sub>p\<Pi>)\<bar>\<Sigma> \<turnstile> consequent \<Longrightarrow> (p2\<and>\<^sub>pp1\<and>\<^sub>p\<Pi>)\<bar>\<Sigma> \<turnstile> consequent"
using entails_def pure_commut_form by simp

subsection \<open>First example (cf. \cite{seminar-paper} 2.4)\<close>
lemma "[\<acute>''x''`\<noteq>\<^sub>p\<acute>p`]\<bar>\<acute>''x''`\<longmapsto>\<acute>''y''` * \<acute>''y''`\<longmapsto>nil * emp \<turnstile> []\<bar>[ls(\<acute>''x''`,nil)]"
\<comment> \<open>First enrich the formula to contain all necessary inequalities, ...\<close>
apply (rule nil_not_lval)
apply (rule spatial_commut_entail)  (* Reordering *)
apply (rule nil_not_lval)
\<comment> \<open>... then destructure the ls step by step, ...\<close>
apply (rule pure_commut_entail)     (* Reordering *)
apply (rule spatial_commut_entail)  (* Reordering *)
apply (rule non_empty_ls)
apply (rule pure_commut_entail)     (* Reordering *)
apply (rule non_empty_ls)
\<comment> \<open>... then exchange the empty ls with emp ...\<close>
apply (rule empty_ls)
\<comment> \<open>... and finally prove the entailment with the axiom. \<close>
by (rule axiom)

subsection \<open>Second example (cf. \cite{seminar-paper} 2.4)\<close>
text \<open>At first try to prove this by applying the decision procedure as far as possible.\<close>
lemma "(\<top>\<bar>\<acute>''x''`\<longmapsto>nil * \<acute>''y''`\<longmapsto>nil * emp \<turnstile> [\<acute>''x''`=\<^sub>p\<acute>''y''`]\<bar>[\<acute>''y''`\<longmapsto>nil])"
\<comment> \<open>First enrich the formula to contain all necessary inequalities, ...\<close>
apply (rule sep_conj_partial)
apply (rule nil_not_lval)
apply (rule spatial_commut_entail)  (* Reordering *)
apply (rule nil_not_lval)
\<comment> \<open>... then remove the duplicate $y\mapsto nil$ ...\<close>
apply (rule frame)
\<comment> \<open>... and there is no applicable rule and so the decision procedure halts.\<close>
sorry

text \<open>The resulting transformed goal can no be proven wrong with a counter example.\<close>
lemma "\<not>([\<acute>''y''`\<noteq>\<^sub>pnil, \<acute>''x''`\<noteq>\<^sub>pnil, \<acute>''x''`\<noteq>\<^sub>p\<acute>''y''`]\<bar>[\<acute>''x''`\<longmapsto>nil] \<turnstile> [\<acute>''x''`=\<^sub>p\<acute>''y''`]\<bar>emp)"
  (is "\<not>(?ant \<turnstile> ?cons)")
proof
  assume "?ant \<turnstile> ?cons"
  hence hyp: "\<forall>s h. (s,h)\<Turnstile>?ant \<longrightarrow> (s,h)\<Turnstile>?cons" using entails_def by simp
  define s h where s_def:"(s::stack) = ((\<lambda>_. Nilval)(''x'':=Val 5))(''y'':=Val 23)"
    and h_def: "(h::heap) = [5\<mapsto>Nilval]"
  have "(s,h)\<Turnstile>?ant" proof \<comment> \<open>The state (s,h) satisfies the antecedent ...\<close>
    show "(s,h)\<Turnstile>PureF (\<acute>''y''`\<noteq>\<^sub>pnil \<and>\<^sub>p \<acute>''x''`\<noteq>\<^sub>pnil \<and>\<^sub>p \<acute>''x''`\<noteq>\<^sub>p\<acute>''y''` \<and>\<^sub>p \<top>)" proof
      show "(s,h)\<Turnstile>Pure (\<acute>''y''`\<noteq>\<^sub>pnil)" by (simp add: NeqSat s_def)
    next
      show "(s,h)\<Turnstile>PureF (\<acute>''x''`\<noteq>\<^sub>pnil \<and>\<^sub>p \<acute>''x''`\<noteq>\<^sub>p\<acute>''y''` \<and>\<^sub>p \<top>)" proof
        show "(s,h)\<Turnstile>Pure (\<acute>''x''`\<noteq>\<^sub>pnil)" by (simp add: NeqSat s_def)
      next
        show "(s,h)\<Turnstile>PureF (\<acute>''x''`\<noteq>\<^sub>p\<acute>''y''` \<and>\<^sub>p \<top>)" proof
          show "(s,h)\<Turnstile>Pure (\<acute>''x''`\<noteq>\<^sub>p\<acute>''y''`)" by (simp add: NeqSat s_def)
        next
          show "(s,h)\<Turnstile>PureF (\<top>)" by auto
        qed
      qed
    qed
  next
    define h1 h2 where h_defs: "h1 = h" "(h2::heap) = Map.empty"
    hence "h1\<bottom>h2" "h=h1++h2" by simp_all
    moreover from h_defs have "(s,h2)\<Turnstile>SpatF emp" by auto
    moreover have "(s,h1)\<Turnstile>Spat (\<acute>''x''`\<longmapsto>nil)" proof
      show "\<lbrakk>\<acute>''x''`\<rbrakk>s = Val 5" using s_def by simp
    next
      show "h1 = [5 \<mapsto> \<lbrakk>nil\<rbrakk>s]" using h_defs h_def by simp
    qed
    ultimately show "(s,h)\<Turnstile>SpatF (\<acute>''x''`\<longmapsto>nil * emp)" by blast
  qed
  with hyp have "(s,h)\<Turnstile>?cons" by simp
  moreover have contradiction: "\<not>(s,h)\<Turnstile>?cons" proof \<comment> \<open>... but not the consequent.\<close>
    assume "(s,h)\<Turnstile>?cons"
    hence "(s,h)\<Turnstile>Pure (\<acute>''x''` =\<^sub>p \<acute>''y''`)" by auto
    hence "\<lbrakk>\<acute>''x''`\<rbrakk>s = \<lbrakk>\<acute>''y''`\<rbrakk>s" by auto
    moreover from s_def have "\<lbrakk>\<acute>''x''`\<rbrakk>s \<noteq> \<lbrakk>\<acute>''y''`\<rbrakk>s" by simp
    ultimately show False by simp
  qed
  ultimately show False by simp
qed
end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header "Structured Reasoning"

theory StructuredReasoning imports Algebra begin

text {* By linking the algebraic, the syntactic, and the semantic views
  of computation, we derive a set of rules for decomposing expectation
  entailment proofs, firstly over the syntactic structure of a program,
  and secondly over the refinement relation.  These rules also form the
  basis for automated reasoning. *}

subsection {* Syntactic Decomposition *}

lemma wp_Abort:
  "(\<lambda>s. 0) \<tturnstile> wp Abort Q"
  unfolding wp_eval by(simp)

lemma wlp_Abort:
  "(\<lambda>s. 1) \<tturnstile> wlp Abort Q"
  unfolding wp_eval by(simp)

lemma wp_Skip:
  "P \<tturnstile> wp Skip P"
  unfolding wp_eval by(blast)

lemma wlp_Skip:
  "P \<tturnstile> wlp Skip P"
  unfolding wp_eval by(blast)

lemma wp_Apply:
  "Q o f \<tturnstile> wp (Apply f) Q"
  unfolding wp_eval by(simp)

lemma wlp_Apply:
  "Q o f \<tturnstile> wlp (Apply f) Q"
  unfolding wp_eval by(simp)

lemma wp_Seq:
  assumes ent_a: "P \<tturnstile> wp a Q"
      and ent_b: "Q \<tturnstile> wp b R"
      and wa:   "well_def a"
      and wb:   "well_def b"
      and s_Q:   "sound Q"
      and s_R:   "sound R"
  shows "P \<tturnstile> wp (a ;; b) R"
proof -
  note ha = well_def_wp_healthy[OF wa]
  note hb = well_def_wp_healthy[OF wb]
  note ent_a
  also from ent_b ha hb s_Q s_R have "wp a Q \<tturnstile> wp a (wp b R)"
    by(blast intro:healthy_monoD2)
  finally show ?thesis by(simp add:wp_eval)
qed

lemma wp_PC:
  "(\<lambda>s. P s * wp a Q s + (1 - P s) * wp b Q s) \<tturnstile> wp (a \<^bsub>P\<^esub>\<oplus> b) Q"
  by(simp add:wp_eval)

lemma wlp_PC:
  "(\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) \<tturnstile> wlp (a \<^bsub>P\<^esub>\<oplus> b) Q"
  by(simp add:wp_eval)

text {* A simpler rule for when the probability does not depend on the state. *}
lemma PC_fixed:
  assumes wpa: "P \<tturnstile> a ab R"
      and wpb: "Q \<tturnstile> b ab R"
      and np: "0 \<le> p" and bp: "p \<le> 1"
  shows "(\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) ab R"
  unfolding PC_def
proof(rule le_funI)
  fix s
  from wpa and np have "p * P s \<le> p * a ab R s"
    by(auto intro:mult_left_mono)
  moreover {
    from bp have "0 \<le> 1 - p" by(simp)
    with wpb have "(1 - p) * Q s \<le> (1 - p) * b ab R s"
      by(auto intro:mult_left_mono)
  }
  ultimately show "p * P s + (1 - p) * Q s \<le>
                   p * a ab R s + (1 - p) * b ab R s"
    by(rule add_mono)
qed

lemma wp_PC_fixed:
  "\<lbrakk> P \<tturnstile> wp a R; Q \<tturnstile> wp b R; 0 \<le> p; p \<le> 1 \<rbrakk> \<Longrightarrow>
  (\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> wp (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) R"
  by(simp add:wp_def PC_fixed)

lemma wlp_PC_fixed:
  "\<lbrakk> P \<tturnstile> wlp a R; Q \<tturnstile> wlp b R; 0 \<le> p; p \<le> 1 \<rbrakk> \<Longrightarrow>
  (\<lambda>s. p * P s + (1 - p) * Q s) \<tturnstile> wlp (a \<^bsub>(\<lambda>s. p)\<^esub>\<oplus> b) R"
  by(simp add:wlp_def PC_fixed)

lemma wp_DC:
  "(\<lambda>s. min (wp a Q s) (wp b Q s)) \<tturnstile> wp (a \<Sqinter> b) Q"
  unfolding wp_eval by(simp)

lemma wlp_DC:
  "(\<lambda>s. min (wlp a Q s) (wlp b Q s)) \<tturnstile> wlp (a \<Sqinter> b) Q"
  unfolding wp_eval by(simp)

text {* Combining annotations for both branches: *}
lemma DC_split:
  fixes a::"'s prog" and b
  assumes wpa: "P \<tturnstile> a ab R"
      and wpb: "Q \<tturnstile> b ab R"
  shows "(\<lambda>s. min (P s) (Q s)) \<tturnstile> (a \<Sqinter> b) ab R"
  unfolding DC_def
proof(rule le_funI)
  fix s
  from wpa wpb
  have "P s \<le> a ab R s" and "Q s \<le> b ab R s" by(auto)
  thus "min (P s) (Q s) \<le> min (a ab R s) (b ab R s)" by(auto)
qed

lemma wp_DC_split:
  "\<lbrakk> P \<tturnstile> wp prog R; Q \<tturnstile> wp prog' R \<rbrakk> \<Longrightarrow>
  (\<lambda>s. min (P s) (Q s)) \<tturnstile> wp (prog \<Sqinter> prog') R"
  by(simp add:wp_def DC_split)

lemma wlp_DC_split:
  "\<lbrakk> P \<tturnstile> wlp prog R; Q \<tturnstile> wlp prog' R \<rbrakk> \<Longrightarrow>
  (\<lambda>s. min (P s) (Q s)) \<tturnstile> wlp (prog \<Sqinter> prog') R"
  by(simp add:wlp_def DC_split)

lemma wp_DC_split_same:
  "\<lbrakk> P \<tturnstile> wp prog Q; P \<tturnstile> wp prog' Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (prog \<Sqinter> prog') Q"
  unfolding wp_eval by(blast intro:min.boundedI)

lemma wlp_DC_split_same:
  "\<lbrakk> P \<tturnstile> wlp prog Q; P \<tturnstile> wlp prog' Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (prog \<Sqinter> prog') Q"
  unfolding wp_eval by(blast intro:min.boundedI)

lemma SetPC_split:
  fixes f::"'x \<Rightarrow> 'y prog"
    and p::"'y \<Rightarrow> 'x \<Rightarrow> real"
  assumes rec: "\<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> f x ab Q"
      and nnp: "\<And>s. nneg (p s)"
  shows "(\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> SetPC f p ab Q"
  unfolding SetPC_def
proof(rule le_funI)
  fix s
  from rec have "\<And>x. x \<in> supp (p s) \<Longrightarrow> P x s \<le> f x ab Q s" by(blast)
  moreover from nnp have "\<And>x. 0 \<le> p s x" by(blast)
  ultimately have "\<And>x. x \<in> supp (p s) \<Longrightarrow> p s x * P x s \<le> p s x * f x ab Q s"
    by(blast intro:mult_left_mono)
  thus "(\<Sum>x \<in> supp (p s). p s x * P x s) \<le> (\<Sum>x \<in> supp (p s). p s x * f x ab Q s)"
    by(rule setsum_mono)
qed

lemma wp_SetPC_split:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> wp (f x) Q; \<And>s. nneg (p s) \<rbrakk> \<Longrightarrow>
   (\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> wp (SetPC f p) Q"
  by(simp add:wp_def SetPC_split)

lemma wlp_SetPC_split:
  "\<lbrakk> \<And>x s. x \<in> supp (p s) \<Longrightarrow> P x \<tturnstile> wlp (f x) Q; \<And>s. nneg (p s) \<rbrakk> \<Longrightarrow>
   (\<lambda>s. \<Sum>x \<in> supp (p s). p s x * P x s) \<tturnstile> wlp (SetPC f p) Q"
  by(simp add:wlp_def SetPC_split)

lemma wp_SetDC_split:
  "\<lbrakk> \<And>s x. x \<in> S s \<Longrightarrow> P \<tturnstile> wp (f x) Q; \<And>s. S s \<noteq> {} \<rbrakk> \<Longrightarrow>
   P \<tturnstile> wp (SetDC f S) Q"
  by(rule le_funI, unfold wp_eval, blast intro!:cInf_greatest)

lemma wlp_SetDC_split:
  "\<lbrakk> \<And>s x. x \<in> S s \<Longrightarrow> P \<tturnstile> wlp (f x) Q; \<And>s. S s \<noteq> {} \<rbrakk> \<Longrightarrow>
   P \<tturnstile> wlp (SetDC f S) Q"
  by(rule le_funI, unfold wp_eval, blast intro!:cInf_greatest)

lemma wp_SetDC:
  assumes wp: "\<And>s x. x \<in> S s \<Longrightarrow> P x \<tturnstile> wp (f x) Q"
      and ne: "\<And>s. S s \<noteq> {}"
      and sP: "\<And>x. sound (P x)"
  shows "(\<lambda>s. Inf ((\<lambda>x. P x s) ` S s)) \<tturnstile> wp (SetDC f S) Q"
  using assms by(intro le_funI, simp add:wp_eval del:Inf_image_eq, blast intro!:cInf_mono)

lemma wlp_SetDC:
  assumes wp: "\<And>s x. x \<in> S s \<Longrightarrow> P x \<tturnstile> wlp (f x) Q"
      and ne: "\<And>s. S s \<noteq> {}"
      and sP: "\<And>x. sound (P x)"
  shows "(\<lambda>s. Inf ((\<lambda>x. P x s) ` S s)) \<tturnstile> wlp (SetDC f S) Q"
  using assms by(intro le_funI, simp add:wp_eval del:Inf_image_eq, blast intro!:cInf_mono)

lemma wp_Embed:
  "P \<tturnstile> t Q \<Longrightarrow> P \<tturnstile> wp (Embed t) Q"
  by(simp add:wp_def Embed_def)

lemma wlp_Embed:
  "P \<tturnstile> t Q \<Longrightarrow> P \<tturnstile> wlp (Embed t) Q"
  by(simp add:wlp_def Embed_def)

lemma wp_Bind:
  "\<lbrakk> \<And>s. P s \<le> wp (a (f s)) Q s \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (Bind f a) Q"
  by(auto simp:wp_def Bind_def)

lemma wlp_Bind:
  "\<lbrakk> \<And>s. P s \<le> wlp (a (f s)) Q s \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (Bind f a) Q"
  by(auto simp:wlp_def Bind_def)

lemma wp_repeat:
  "\<lbrakk> P \<tturnstile> wp a Q; Q \<tturnstile> wp (repeat n a) R;
     well_def a; sound Q; sound R \<rbrakk> \<Longrightarrow> P \<tturnstile> wp (repeat (Suc n) a) R"
  by(auto intro!:wp_Seq wd_intros)

lemma wlp_repeat:
  "\<lbrakk> P \<tturnstile> wlp a Q; Q \<tturnstile> wlp (repeat n a) R;
     well_def a; unitary Q; unitary R \<rbrakk> \<Longrightarrow> P \<tturnstile> wlp (repeat (Suc n) a) R"
  by(auto intro!:wlp_Seq wd_intros)

text {* Note that the loop rules presented in section \autoref{s:loop_rules} are of the same form,
and would belong here, had they not already been stated. *}

text {* The following rules are specialisations of those for general
  transformers, and are easier for the unifier to match. *}
lemmas wp_strengthen_post=
  entails_strengthen_post[where t="wp a" for a]

lemma wlp_strengthen_post:
  "P \<tturnstile> wlp a Q \<Longrightarrow> nearly_healthy (wlp a) \<Longrightarrow> unitary R \<Longrightarrow> Q \<tturnstile> R \<Longrightarrow> unitary Q \<Longrightarrow>
   P \<tturnstile> wlp a R"
  by(blast intro:entails_trans)

lemmas wp_weaken_pre=
  entails_weaken_pre[where t="wp a" for a]
lemmas wlp_weaken_pre=
  entails_weaken_pre[where t="wlp a" for a]

lemmas wp_scale=
  entails_scale[where t="wp a" for a, OF _ well_def_wp_healthy]

subsection {* Algebraic Decomposition *}

text {* Refinement is a powerful tool for decomposition, belied by the simplicity of the rule.
This is an \emph{axiomatic} formulation of refinement (all annotations of the @{term a}
are annotations of @{term b}), rather than an operational version (all traces of @{term b} are
traces of @{term a}. *}

lemma wp_refines:
  "\<lbrakk> a \<sqsubseteq> b; P \<tturnstile> wp a Q; sound Q \<rbrakk> \<Longrightarrow> P \<tturnstile> wp b Q"
  by(auto intro:entails_trans)

lemmas wp_drefines = drefinesD

subsection {* Hoare triples *}

text {* The Hoare triple, or validity predicate, is logically equivalent to the weakest-precondition
entailment form. The benefit is that it allows us to define transitivity rules for computational
(also/finally) reasoning. *}

definition
  wp_valid :: "('a \<Rightarrow> real) \<Rightarrow> 'a prog \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>p")
where
  "wp_valid P prog Q \<equiv> P \<tturnstile> wp prog Q"

lemma wp_validI:
  "P \<tturnstile> wp prog Q \<Longrightarrow> \<lbrace>P\<rbrace> prog \<lbrace>Q\<rbrace>p"
  unfolding wp_valid_def by(assumption)

lemma wp_validD:
  "\<lbrace>P\<rbrace> prog \<lbrace>Q\<rbrace>p \<Longrightarrow> P \<tturnstile> wp prog Q"
  unfolding wp_valid_def by(assumption)

lemma valid_Seq:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>p; \<lbrace>Q\<rbrace> b \<lbrace>R\<rbrace>p; well_def a; well_def b; sound Q; sound R \<rbrakk> \<Longrightarrow>
  \<lbrace>P\<rbrace> a ;; b \<lbrace>R\<rbrace>p"
  unfolding wp_valid_def by(rule wp_Seq)

text {* We make it available to the computational reasoner: *}
declare valid_Seq[trans]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Enumeration extensions and alternative definition"

theory Enumeration
imports Main
begin

abbreviation
  "enum \<equiv> enum_class.enum"
abbreviation
  "enum_all \<equiv> enum_class.enum_all"
abbreviation
  "enum_ex \<equiv> enum_class.enum_ex"

primrec (nonexhaustive)
  the_index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
where
  "the_index (x # xs) y = (if x = y then 0 else Suc (the_index xs y))"

lemma the_index_bounded:
  "x \<in> set xs \<Longrightarrow> the_index xs x < length xs"
  by (induct xs, clarsimp+)

lemma nth_the_index:
  "x \<in> set xs \<Longrightarrow> xs ! the_index xs x = x"
  by (induct xs, clarsimp+)

lemma distinct_the_index_is_index[simp]:
  "\<lbrakk> distinct xs ; n < length xs \<rbrakk> \<Longrightarrow> the_index xs (xs ! n) = n"
  by (meson nth_eq_iff_index_eq nth_mem nth_the_index the_index_bounded)

lemma the_index_last_distinct:
  "distinct xs \<and> xs \<noteq> [] \<Longrightarrow> the_index xs (last xs) = length xs - 1"
  apply safe
  apply (subgoal_tac "xs ! (length xs - 1) = last xs")
   apply (subgoal_tac "xs ! the_index xs (last xs) = last xs")
    apply (subst nth_eq_iff_index_eq[symmetric])
       apply assumption
      apply (rule the_index_bounded)
      apply simp_all
   apply (rule nth_the_index)
   apply simp
  apply (induct xs, auto)
  done

context enum begin

(* These two are added for historical reasons. *)
lemmas enum_surj[simp] = enum_UNIV
declare enum_distinct[simp]

lemma enum_nonempty[simp]: "(enum :: 'a list) \<noteq> []"
  using enum_surj by fastforce

definition
  maxBound :: 'a where
  "maxBound \<equiv> last enum"

definition
  minBound :: 'a where
  "minBound \<equiv> hd enum"

definition
  toEnum :: "nat \<Rightarrow> 'a" where
  "toEnum n \<equiv> if n < length (enum :: 'a list) then enum ! n else the None"

definition
  fromEnum :: "'a \<Rightarrow> nat" where
  "fromEnum x \<equiv> the_index enum x"

lemma maxBound_is_length:
  "fromEnum maxBound = length (enum :: 'a list) - 1"
  by (simp add: maxBound_def fromEnum_def the_index_last_distinct)

lemma maxBound_less_length:
  "(x \<le> fromEnum maxBound) = (x < length (enum :: 'a list))"
  unfolding maxBound_is_length by (cases "length enum") auto

lemma maxBound_is_bound [simp]:
  "fromEnum x \<le> fromEnum maxBound"
  unfolding maxBound_less_length
  by (fastforce simp: fromEnum_def intro: the_index_bounded)

lemma to_from_enum [simp]:
  fixes x :: 'a
  shows "toEnum (fromEnum x) = x"
proof -
  have "x \<in> set enum" by simp
  then show ?thesis by (simp add: toEnum_def fromEnum_def nth_the_index the_index_bounded)
qed

lemma from_to_enum [simp]:
  "x \<le> fromEnum maxBound \<Longrightarrow> fromEnum (toEnum x) = x"
  unfolding maxBound_less_length by (simp add: toEnum_def fromEnum_def)

lemma map_enum:
  fixes x :: 'a
  shows "map f enum ! fromEnum x = f x"
proof -
  have "fromEnum x \<le> fromEnum (maxBound :: 'a)"
    by (rule maxBound_is_bound)
  then have "fromEnum x < length (enum::'a list)"
    by (simp add: maxBound_less_length)
  then have "map f enum ! fromEnum x = f (enum ! fromEnum x)" by simp
  also
  have "x \<in> set enum" by simp
  then have "enum ! fromEnum x = x"
    by (simp add: fromEnum_def nth_the_index)
  finally
  show ?thesis .
qed

definition
  assocs :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list" where
 "assocs f \<equiv> map (\<lambda>x. (x, f x)) enum"

end

(* For historical naming reasons. *)
lemmas enum_bool = enum_bool_def

lemma fromEnumTrue [simp]: "fromEnum True = 1"
  by (simp add: fromEnum_def enum_bool)

lemma fromEnumFalse [simp]: "fromEnum False = 0"
  by (simp add: fromEnum_def enum_bool)

class enum_alt =
  fixes enum_alt :: "nat \<Rightarrow> 'a option"

class enumeration_alt = enum_alt +
  assumes enum_alt_one_bound:
    "enum_alt x = (None :: 'a option) \<Longrightarrow> enum_alt (Suc x) = (None :: 'a option)"
  assumes enum_alt_surj:
    "range enum_alt \<union> {None} = UNIV"
  assumes enum_alt_inj:
    "(enum_alt x :: 'a option) = enum_alt y \<Longrightarrow> (x = y) \<or> (enum_alt x = (None :: 'a option))"
begin

lemma enum_alt_inj_2:
  assumes "enum_alt x = (enum_alt y :: 'a option)"
          "enum_alt x \<noteq> (None :: 'a option)"
  shows "x = y"
proof -
  from assms
  have "(x = y) \<or> (enum_alt x = (None :: 'a option))" by (fastforce intro!: enum_alt_inj)
  with assms show ?thesis by clarsimp
qed

lemma enum_alt_surj_2:
  "\<exists>x. enum_alt x = Some y"
proof -
  have "Some y \<in> range enum_alt \<union> {None}" by (subst enum_alt_surj) simp
  then have "Some y \<in> range enum_alt" by simp
  then show ?thesis by auto
qed

end

definition
  alt_from_ord :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option"
where
  "alt_from_ord L \<equiv> \<lambda>n. if (n < length L) then Some (L ! n) else None"

lemma handy_if_lemma: "((if P then Some A else None) = Some B) = (P \<and> (A = B))"
  by simp

class enumeration_both = enum_alt + enum +
  assumes enum_alt_rel: "enum_alt = alt_from_ord enum"

instance enumeration_both < enumeration_alt
  apply (intro_classes; simp add: enum_alt_rel alt_from_ord_def)
    apply auto[1]
   apply (safe; simp)[1]
   apply (rule rev_image_eqI; simp)
    apply (rule the_index_bounded; simp)
   apply (subst nth_the_index; simp)
  apply (clarsimp simp: handy_if_lemma)
  apply (subst nth_eq_iff_index_eq[symmetric]; simp)
  done

instantiation bool :: enumeration_both
begin
  definition enum_alt_bool: "enum_alt \<equiv> alt_from_ord [False, True]"
  instance by (intro_classes, simp add: enum_bool_def enum_alt_bool)
end

definition
  toEnumAlt :: "nat \<Rightarrow> ('a :: enum_alt)" where
 "toEnumAlt n \<equiv> the (enum_alt n)"

definition
  fromEnumAlt :: "('a :: enum_alt) \<Rightarrow> nat" where
 "fromEnumAlt x \<equiv> THE n. enum_alt n = Some x"

definition
  upto_enum :: "('a :: enumeration_alt) \<Rightarrow> 'a \<Rightarrow> 'a list" ("(1[_ .e. _])") where
 "upto_enum n m \<equiv> map toEnumAlt [fromEnumAlt n ..< Suc (fromEnumAlt m)]"

lemma fromEnum_alt_red[simp]:
  "fromEnumAlt = (fromEnum :: ('a :: enumeration_both) \<Rightarrow> nat)"
  apply (rule ext)
  apply (simp add: fromEnumAlt_def fromEnum_def enum_alt_rel alt_from_ord_def)
  apply (rule theI2)
    apply (rule conjI)
     apply (clarify, rule nth_the_index, simp)
    apply (rule the_index_bounded, simp)
   apply auto
  done

lemma toEnum_alt_red[simp]:
  "toEnumAlt = (toEnum :: nat \<Rightarrow> 'a :: enumeration_both)"
  by (rule ext) (simp add: enum_alt_rel alt_from_ord_def toEnum_def toEnumAlt_def)

lemma upto_enum_red:
  "[(n :: ('a :: enumeration_both)) .e. m] = map toEnum [fromEnum n ..< Suc (fromEnum m)]"
  unfolding upto_enum_def by simp

instantiation nat :: enumeration_alt
begin
  definition enum_alt_nat: "enum_alt \<equiv> Some"
  instance by (intro_classes; simp add: enum_alt_nat UNIV_option_conv)
end

lemma toEnumAlt_nat[simp]: "toEnumAlt = id"
  by (rule ext) (simp add: toEnumAlt_def enum_alt_nat)

lemma fromEnumAlt_nat[simp]: "fromEnumAlt = id"
  by (rule ext) (simp add: fromEnumAlt_def enum_alt_nat)

lemma upto_enum_nat[simp]: "[n .e. m] = [n ..< Suc m]"
  by (subst upto_enum_def) simp

definition
  zipE1 :: "'a :: enum_alt \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE1 x L \<equiv> zip (map toEnumAlt [fromEnumAlt x ..< fromEnumAlt x + length L]) L"

definition
  zipE2 :: "'a :: enum_alt \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE2 x xn L \<equiv> zip (map (\<lambda>n. toEnumAlt (fromEnumAlt x + (fromEnumAlt xn - fromEnumAlt x) * n))
                      [0 ..< length L]) L"

definition
  zipE3 :: "'a list \<Rightarrow> 'b :: enum_alt \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE3 L x \<equiv> zip L (map toEnumAlt [fromEnumAlt x ..< fromEnumAlt x + length L])"

definition
  zipE4 :: "'a list \<Rightarrow> 'b :: enum_alt \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE4 L x xn \<equiv> zip L (map (\<lambda>n. toEnumAlt (fromEnumAlt x + (fromEnumAlt xn - fromEnumAlt x) * n))
                         [0 ..< length L])"

lemma to_from_enum_alt[simp]:
  "toEnumAlt (fromEnumAlt x) = (x :: 'a :: enumeration_alt)"
proof -
  have rl: "\<And>a b. a = Some b \<Longrightarrow> the a = b" by simp
  show ?thesis
    unfolding fromEnumAlt_def toEnumAlt_def
    by (rule rl, rule theI') (metis enum_alt_inj enum_alt_surj_2 not_None_eq)
qed

lemma upto_enum_triv [simp]: "[x .e. x] = [x]"
  unfolding upto_enum_def by simp

lemma toEnum_eq_to_fromEnum_eq:
  fixes v :: "'a :: enum"
  shows "n \<le> fromEnum (maxBound :: 'a) \<Longrightarrow> (toEnum n = v) = (n = fromEnum v)"
  by auto

lemma le_imp_diff_le:
  "(j::nat) \<le> k \<Longrightarrow> j - n \<le> k"
  by simp

lemma fromEnum_upto_nth:
  fixes start :: "'a :: enumeration_both"
  assumes "n < length [start .e. end]"
  shows "fromEnum ([start .e. end] ! n) = fromEnum start + n"
proof -
  have less_sub: "\<And>m k m' n. \<lbrakk> (n::nat) < m - k ; m \<le> m' \<rbrakk> \<Longrightarrow> n < m' - k" by fastforce
  note upt_Suc[simp del]
  show ?thesis using assms
  by (fastforce simp: upto_enum_red
                dest: less_sub[where m'="Suc (fromEnum maxBound)"] intro: maxBound_is_bound)
qed

lemma length_upto_enum_le_maxBound:
  fixes start :: "'a :: enumeration_both"
  shows "length [start .e. end] \<le> Suc (fromEnum (maxBound :: 'a))"
  apply (clarsimp simp add: upto_enum_red split: if_splits)
  apply (rule le_imp_diff_le[OF maxBound_is_bound[of "end"]])
  done

lemma less_length_upto_enum_maxBoundD:
  fixes start :: "'a :: enumeration_both"
  assumes "n < length [start .e. end]"
  shows "n \<le> fromEnum (maxBound :: 'a)"
  using assms
  by (simp add: upto_enum_red less_Suc_eq_le
                le_trans[OF _ le_imp_diff_le[OF maxBound_is_bound[of "end"]]]
           split: if_splits)

lemma fromEnum_eq_iff:
  "(fromEnum e = fromEnum f) = (e = f)"
proof -
  have a: "e \<in> set enum" by auto
  have b: "f \<in> set enum" by auto
  from nth_the_index[OF a] nth_the_index[OF b] show ?thesis unfolding fromEnum_def by metis
qed

lemma maxBound_is_bound':
  "i = fromEnum (e::('a::enum)) \<Longrightarrow> i \<le> fromEnum (maxBound::('a::enum))"
  by clarsimp

end


theory Category_Instances
imports Category Orders
begin

definition "mono_rel R \<equiv> \<forall>r\<in>R. \<forall>r'\<in>R. fst r \<le> fst r' \<longrightarrow> snd r \<le> snd r'"

abbreviation inject_delta  ("\<langle>_\<rangle>") where
"inject_delta (n :: nat) \<equiv> {0..n}"

definition "delta_hom_set  \<equiv> {(n,f, k). single_valued f \<and> mono_rel f \<and> fst ` f = inject_delta n \<and> snd ` f = inject_delta k} "

lemma set_eq_singletonD: "{x} = S \<Longrightarrow> \<forall>y\<in>S. x = y"
  apply (blast)
  done

lemma suc_image: "a ` \<langle>Suc n\<rangle> = (a ` \<langle>n\<rangle>) \<union> {a (Suc n)}"
  apply (safe; clarsimp)
  using le_Suc_eq by auto

lemma card_image: "card (a ` \<langle>n\<rangle>) \<le> (Suc n)"
  apply (induct n, clarsimp)
  apply (clarsimp simp: suc_image)
  by (simp add: card_insert_le_m1)

lemma fun_finite_card: "single_valued r \<Longrightarrow>  card (fst ` r) \<ge> card (snd ` r)"
  apply (case_tac "finite r")
  apply (clarsimp)
  apply (rule card_le_if_inj_on_rel[where r="\<lambda>x y. (x, y) \<in> converse r"], blast)
   apply (metis (no_types, opaque_lifting) converseI imageE image_eqI surjective_pairing)
  apply (drule converseD)+
   apply (erule (2) single_valuedD)
  apply (clarsimp)
  oops

lemma fst_image_singleton:  "fst ` R = S \<Longrightarrow> (converse R) `` (snd ` R) = S "
  apply (safe, clarsimp simp: image_iff)
   apply (metis fst_eqD)
  apply (clarsimp simp: image_iff Image_iff)
  by (metis  snd_eqD)

lemma helper: "single_valued R \<Longrightarrow> x \<in> (snd ` R) \<Longrightarrow> y \<in> (snd ` R) \<Longrightarrow>  converse R `` {x} \<inter> converse R `` {y} = converse R `` ({x} \<inter> {y}) "
  apply (clarsimp)
  apply (safe, clarsimp simp: Image_iff)
  by (erule (2) single_valuedD)

lemma not_le_natD: "\<not> x \<le> y \<Longrightarrow> y \<le> (x :: nat)"
  by linarith

lemma finite_descent: "finite F \<Longrightarrow> \<not> P {}  \<Longrightarrow> (\<And>F. P F \<Longrightarrow>finite F \<Longrightarrow>  \<exists>F'. F' \<subset> F \<and> P (F')) \<Longrightarrow> \<not> P F"
  apply (clarsimp)
  apply (induct F rule: finite_psubset_induct; clarsimp)
  apply (atomize)
  apply (clarsimp)
  by auto

definition "card_ord S S' \<equiv> \<exists>f. inj_on f S \<and> f ` S \<subseteq> S'"

definition some_elem :: "'a set \<Rightarrow> 'a"
  where "some_elem X = (SOME x. x \<in> X)"

lemma some_elem_eq [simp]: "X \<noteq> {} \<Longrightarrow>some_elem X \<in> X "
  apply (simp add: some_elem_def)
  using some_in_eq by fastforce

find_consts "'a set \<Rightarrow> 'a"

lemma functional_codomain_le_dom:"single_valued R \<Longrightarrow> card_ord (snd ` R) (fst ` R)"
  apply (clarsimp simp: card_ord_def)
  apply (rule_tac x="\<lambda>x. some_elem (converse R `` {x})" in exI)
  apply (intro conjI)
   apply (rule inj_onI; clarsimp)

   apply (metis Image_singleton_iff converseD converseI empty_iff single_valuedD some_elem_eq)
  apply (clarsimp simp: image_iff)
  by (metis Image_singleton_iff converseD converseI empty_iff fst_conv some_elem_eq)

lemma psubset_implies_card_ord: "X \<subseteq> Y \<Longrightarrow> card_ord X Y"
  apply (subst card_ord_def)
  apply (rule_tac x="id" in exI)
  apply (clarsimp)
  done

lemma finite_implies_psubset_not_card_ord: "finite X \<Longrightarrow> card_ord Y X \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> X = Y "
  apply (induct X arbitrary: Y rule:finite_induct; clarsimp simp :card_ord_def)
  apply (atomize)
  apply (erule_tac x="Y - {x}" in allE, clarsimp)
  apply (drule mp)
   defer
  apply (drule mp)
    apply (clarsimp)
  apply (blast)
   apply fastforce
  apply (rule_tac x="(\<lambda>v. if f v = x then (f x) else f v)" in exI)
  apply (intro conjI)
   apply (rule inj_onI; clarsimp)
   apply (clarsimp split: if_splits)
     apply (metis inj_on_contraD)
     apply (metis inj_on_contraD)
     apply (metis inj_on_contraD)
   apply (metis inj_on_contraD)
  apply (clarsimp)
  apply (intro conjI)
   apply (clarsimp)
   apply (metis imageI in_mono inj_on_contraD insertE)
  by blast

locale delta_hom
begin

sublocale  Hom_Syntax delta_hom_set relcomp done

end

context delta_hom begin

abbreviation "delta_hom \<equiv> hom_of "

lemmas delta_hom_def = hom_of_def

term "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"

thm delta_hom_set_def

lemma arr_iff: "\<guillemotleft>f : n \<rightarrow> k\<guillemotright> \<longleftrightarrow> single_valued f \<and> mono_rel f \<and> fst ` f = \<langle>n\<rangle> \<and> snd ` f = \<langle>k\<rangle>"
  apply (clarsimp simp: delta_hom_set_def)
  done

lemma delta_hom_le: "n < k \<Longrightarrow> delta_hom n k = {}"
  apply (clarsimp simp: delta_hom_def arr_iff)
  apply (drule functional_codomain_le_dom)
  apply (drule finite_implies_psubset_not_card_ord[rotated])
    apply (clarsimp)+
  done

(*

lemma "single_valued x \<Longrightarrow> mono_rel x \<Longrightarrow> fst ` x = \<langle>k\<rangle> \<Longrightarrow> snd ` x = \<langle>k\<rangle> \<Longrightarrow> (a, b) \<in> x \<Longrightarrow> a \<le> b"
  apply (induct a arbitrary: b; clarsimp)
  apply (atomize)
  oops

lemma delta_hom_eq: "  delta_hom k k = {Id_on \<langle>k\<rangle>  }"
  apply (clarsimp simp: delta_hom_def Id_on_def )
  apply (rule order.antisym)
  apply (induct k; clarsimp)
    apply (safe; clarsimp)
  apply (clarsimp simp: arr_iff)
      apply (metis fst_eqD insert_image singleton_insert_inj_eq')
  apply (clarsimp simp: arr_iff)
     apply (metis snd_eqD insert_image singleton_insert_inj_eq')
    apply (clarsimp simp: arr_iff)

    apply (metis (no_types, opaque_lifting) image_iff prod.exhaust_sel singleton_iff)
  apply (drule_tac c="restrict x {Suc k}" in subsetD)
    apply (clarsimp simp: arr_iff)
    apply (intro conjI; clarsimp?)
       apply (intro single_valuedI; clarsimp simp: restrict_iff)
       apply (meson single_valued_def)
      apply (clarsimp simp: mono_rel_def restrict_iff)
      apply (metis fst_eqD snd_eqD)
     apply (safe; clarsimp simp: restrict_iff)
      apply (metis atLeastAtMost_iff fst_eqD imageI le_SucE)
     apply (clarsimp simp: image_iff restrict_iff Bex_def)
  apply (metis atLeast0AtMost atMost_iff imageE le_Suc_eq prod.exhaust_sel)
    apply (safe; clarsimp simp: restrict_iff)
     defer
     apply (clarsimp simp: image_iff restrict_iff Bex_def)
     defer
     apply (clarsimp simp: arr_iff)
     apply (safe; clarsimp)
  apply (intro conjI)

       apply (metis (no_types, lifting) atMost_atLeast0 atMost_iff fst_eqD imageI)
  apply (case_tac "a < Suc k")
       apply (smt (verit, best) UN_E less_SucI not_less_eq old.prod.inject restrict_iff singletonD)
      apply (subgoal_tac "a = Suc k"; clarsimp?)
       apply (rule ccontr)
       apply (metis (no_types, opaque_lifting) atLeastAtMost_iff fst_eqD
                   imageE imageI le_antisym mono_rel_def snd_eqD)
      apply (metis (no_types, lifting) atMost_atLeast0 atMost_iff
                      fst_eqD imageI less_Suc_eq_le less_antisym)
  apply (subgoal_tac "xa \<le> k \<or> xa = Suc k", elim disjE ; clarsimp?)
  using restrict_iff apply fastforce
     apply (rule ccontr)
     apply (clarsimp simp: mono_rel_def)
     apply (subgoal_tac "\<exists>v. (Suc k, v) \<in> x")
     apply (subgoal_tac "\<exists>v. (v, Suc k) \<in> x")

      apply (clarsimp)
       apply (erule_tac x="(va, Suc k)" in ballE, clarsimp)
       apply (erule_tac x="(Suc k, v)" in ballE, clarsimp)
  apply (drule mp)
          apply (metis (no_types, opaque_lifting) atLeastAtMost_iff imageI prod.sel(1))
         apply (metis (mono_tags, opaque_lifting) atLeastAtMost_iff atLeastAtMost_singleton
            imageI prod.sel(2) singletonD)
        apply blast
       apply blast
      apply (drule set_eqD)+
      apply (erule_tac x="Suc k" in allE, fastforce)

      apply (drule set_eqD)+
     apply (erule_tac x="Suc k" in allE, fastforce)
    apply (clarsimp simp: arr_iff)
  apply (intro conjI)
  sledgehammer
  using single_valued_def apply auto[1]
      apply (clarsimp simp: mono_rel_def)
     apply (safe; clarsimp simp: image_iff)
    apply (safe; clarsimp simp: image_iff)
      apply (clarsimp simp: mono_rel_def)
  oops
 *)

lemma indices_eq: "y \<in> delta_hom k k' \<Longrightarrow> y \<in> delta_hom na ka \<longleftrightarrow> k = na \<and> k' = ka"
  by (clarsimp simp: delta_hom_def arr_iff)

lemma dom_relcomp: "snd ` y \<subseteq> fst ` z \<Longrightarrow> fst ` (y O z) = fst ` y"
  apply (safe; clarsimp)
   apply (metis fst_conv image_iff)
  apply (clarsimp simp: image_iff Bex_def relcomp.simps)
  by (metis (no_types, lifting) image_iff image_subset_iff prod.collapse snd_conv)

lemma cod_relcomp: "fst ` z \<subseteq> snd ` y \<Longrightarrow> snd ` (y O z) = snd ` z"
  apply (safe; clarsimp)
   apply (metis snd_conv image_iff)
  apply (clarsimp simp: image_iff Bex_def relcomp.simps)
  by (metis (no_types, lifting) image_iff image_subset_iff prod.collapse fst_conv)

lemma in_hom_iff: "f \<in> delta_hom n k \<longleftrightarrow> \<guillemotleft>f : n \<rightarrow> k \<guillemotright>"
  by (clarsimp simp: delta_hom_def arr_iff)

lemma comp_indices_eq: "y \<in> delta_hom n k \<Longrightarrow> z \<in> delta_hom k k' \<Longrightarrow>
     y O z \<in> delta_hom a b \<longleftrightarrow>  a = n \<and> b = k'"
  apply (clarsimp simp: delta_hom_def arr_iff, intro iffI conjI; clarsimp)
        apply (clarsimp simp add: delta_hom_def dom_relcomp dual_order.refl less_nat_zero_code linorder_not_less)
      apply (simp add: atLeast0AtMost cod_relcomp)
     apply (meson single_valued_relcomp)
    apply (clarsimp simp: mono_rel_def)
    apply (metis fst_conv snd_conv)
   apply (simp add: dom_relcomp)
  apply (simp add: cod_relcomp)
  done

thm comp_indices_eq[simplified in_hom_iff]

lemma Id_on_in_hom_n_n:"Id_on \<langle>n\<rangle> \<in> delta_hom n n"
  apply (clarsimp simp: delta_hom_def arr_iff, intro conjI)
    apply (clarsimp simp: mono_rel_def )
   apply (intro set_eqI iffI; clarsimp simp: Id_on_def image_iff)
  by (intro set_eqI iffI; clarsimp simp: Id_on_def image_iff)

lemma id_on_delta_hom_iff: "Id_on \<langle>n\<rangle> \<in> delta_hom a b \<longleftrightarrow> (a = n \<and> b = n)"
  apply (intro iffI)
  using Id_on_in_hom_n_n indices_eq apply blast
  by ( clarsimp simp: Id_on_in_hom_n_n )

lemma in_hom_le[simp]: "x \<in> delta_hom n k \<Longrightarrow> (a, b) \<in> x \<Longrightarrow> a \<le> n"
  apply (clarsimp simp: delta_hom_def arr_iff)
  by (metis atLeastAtMost_iff fst_eqD imageI)

lemma in_hom_le'[simp]: "x \<in> delta_hom n k \<Longrightarrow> (a, b) \<in> x \<Longrightarrow> b \<le> k"
  apply (clarsimp simp: delta_hom_def arr_iff )
  by (metis atLeastAtMost_iff snd_eqD imageI)

sublocale  unital_magma relcomp "Id_on ` range inject_delta"
  apply (standard; clarsimp)
  oops

lemma id_on_fst [simp, elim]: "(x, y) \<in> f \<Longrightarrow> (x,  x) \<in> Id_on (fst ` f)"
  by (clarsimp simp: Id_on_def, metis fst_conv)

lemma id_on_snd [simp, elim]: "(y, x) \<in> f \<Longrightarrow> (x,  x) \<in> Id_on (snd ` f)"
  by (clarsimp simp: Id_on_def, metis snd_conv)

lemma Id_on_idemp[simp]: "Id_on x O Id_on x = Id_on x"
  apply (safe; clarsimp)
  apply (intro relcompI)
   apply (blast)+
  done

end

sublocale delta_hom < delta_pre_cat: pre_category "relcomp" delta_hom_set
  apply (standard; (clarsimp simp: id_on_delta_hom_iff arrows_iff )?)
      apply (rule_tac x="(Id_on (fst ` x))" in bexI, clarsimp)
       apply (intro set_eqI iffI; clarsimp)
       apply (rule relcompI[OF id_on_fst]; assumption)
  apply (clarsimp simp: magma.idems_def image_iff Bex_def arrows_iff)
  using Id_on_in_hom_n_n arr_iff hom_of_def apply force
     apply (rule_tac x="(Id_on (snd ` x))" in bexI, clarsimp)

      apply (intro set_eqI iffI; clarsimp)
      apply (rule relcompI[OF _ id_on_snd]; assumption)

  apply (clarsimp simp: magma.idems_def image_iff Bex_def arrows_iff)
  using Id_on_in_hom_n_n arr_iff hom_of_def apply force

    apply (safe; (clarsimp simp: compatible_iff )?)
     apply (clarsimp simp: carrier_def indices_eq[simplified in_hom_iff] comp_indices_eq[simplified in_hom_iff] image_iff)
    apply (clarsimp simp: carrier_def indices_eq[simplified in_hom_iff] comp_indices_eq[simplified in_hom_iff] image_iff)
   apply (clarsimp simp: O_assoc)
  apply (intro conjI)
  using Id_on_in_hom_n_n in_hom_iff apply blast
  using Id_on_in_hom_n_n in_hom_iff apply blast
  done

sublocale delta_hom \<subseteq> delta_cat: category "relcomp" delta_hom_set
  apply (standard; (clarsimp simp: id_on_delta_hom_iff )?)
  apply (rule_tac a="Id_on \<langle>a\<rangle>" in ex1I, clarsimp?)
   apply (intro conjI)
     apply (clarsimp simp: delta_pre_cat.in_units_iff[OF Id_on_in_hom_n_n[simplified in_hom_iff]] )
    apply (rule Id_on_in_hom_n_n[simplified in_hom_iff])
   apply (clarsimp)
   apply (intro conjI; clarsimp)

    apply (intro set_eqI iffI; clarsimp)

    apply (metis Id_on_iff delta_hom.arr_iff fst_eqD relcomp.relcompI rev_image_eqI)
   apply (intro set_eqI iffI; clarsimp)
    apply (metis Id_on_iff delta_hom.arr_iff snd_eqD relcomp.relcompI rev_image_eqI)
  apply (clarsimp simp: delta_pre_cat.in_units_iff[OF Id_on_in_hom_n_n[simplified in_hom_iff]] )
  apply (clarsimp simp: delta_pre_cat.a.idems_def)
  apply (clarsimp simp: arrows_def arr_iff)
  apply (safe; clarsimp simp: Id_on_def)
  apply (drule set_eqD)
   apply (metis Id_on_iff Id_on_in_hom_n_n arr_iff id_on_fst in_hom_iff in_hom_le' relcomp.relcompI)
  apply (erule_tac x="Id_on \<langle>a\<rangle>" in allE)
  apply (drule set_eqD)
  apply (clarsimp)
  apply (drule mp)

  using Id_on_in_hom_n_n arr_iff in_hom_iff apply auto[1]
  apply (drule mp)
  using Id_on_in_hom_n_n arr_iff in_hom_iff apply auto[1]
  apply (drule set_eqD)
  apply (drule set_eqD)
  apply (drule set_eqD)
  apply (drule set_eqD)
  apply (drule set_eqD)
  apply (clarsimp simp: relcomp.simps)
  by (metis Id_on_iff atLeastAtMost_iff le0)

locale ord_semilattice = poset R + abel_semigroup "carrier R \<times> carrier R" meet "carrier R"
  for R :: "'a rel"  and  meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" +
  assumes
   meet_le: "a \<in> carrier R \<Longrightarrow> b \<in> carrier R \<Longrightarrow> (meet a b, a) \<in> R" and
   meet_greatest: "(a, b) \<in> R \<Longrightarrow> (a, c) \<in> R \<Longrightarrow>  (a, meet b c) \<in> R"

lemma [intro, simp]:" mono_rel x \<Longrightarrow> mono_rel y \<Longrightarrow> mono_rel (y \<inter> z)"
  by (clarsimp simp: mono_rel_def)

abbreviation "proj f S \<equiv> project f (uminus S)"

lemma proj_iff: "proj f S = f \<inter> (UNIV \<times> S)"
  by (safe; clarsimp simp: project_iff)

definition "to_list f = sorted_list_of_set f"

definition "count f = {(a, b). b \<in> snd ` f \<and> a = card (converse f `` {b})}"

definition "meet_deg_count f g = {(a,b). \<exists>x y. (x,b) \<in> f \<and> (y,b) \<in> g \<and> a = max x y}"

definition "list_rep xs = {(a,b). xs ! a = b \<and> Suc a \<le> length xs}"

locale list_delta begin

definition "list_delta_hom_set = {(m, xs, n). length xs = Suc m \<and> sorted xs \<and> set xs = \<langle>n\<rangle>}"

definition "map_compose xs ys = map ((!) ys) xs"

notation map_compose (infixl "\<circ>\<^sub>m" 55)

sublocale Hom_Syntax list_delta_hom_set map_compose done

abbreviation "list_delta_hom \<equiv> hom_of"

lemmas list_delta_hom_def = hom_of_def

lemma arr_iff: "\<guillemotleft> xs : n \<rightarrow> k \<guillemotright> \<longleftrightarrow> length xs = Suc n \<and> sorted xs \<and> set xs = \<langle>k\<rangle> "
  by (clarsimp simp: list_delta_hom_set_def)

lemma list_indices_eq[simp]: "y \<in> list_delta_hom k k' \<Longrightarrow> y \<in> list_delta_hom na ka \<longleftrightarrow> k = na \<and> k' = ka"
  by (clarsimp simp: list_delta_hom_def arr_iff)

lemma set_upto_length: "set y = \<langle>n\<rangle> \<Longrightarrow> length y \<ge> n"
  by (metis Suc_le_lessD card_atLeastAtMost card_length diff_zero order_less_imp_le)

lemma sort_sort_append: "sort (x @ sort xs) = sort (x @ xs)"
  apply (induct xs arbitrary: x; clarsimp?)
  apply (clarsimp simp: sort_key_def)
  by (metis sort_key_def sort_key_simps(2) sorted_sort sorted_sort_id)

lemma sort_commute_append: "sort (x @ y) = sort (y @ x)"
  apply (induct x arbitrary: y; clarsimp?)
  apply (clarsimp simp: sort_key_def)
  by (smt (verit, ccfv_threshold) append_Cons fold_append foldr_conv_fold o_apply sort_conv_fold sort_key_simps(2))

lemma mono_sorted: "sorted xs \<Longrightarrow> mono_on  (set xs) f \<Longrightarrow> sorted (map f xs)"
  apply (induct xs; clarsimp)
  apply (intro conjI)
   apply (simp add: mono_onD)
  using mono_on_subset by blast

lemma list_delta_hom_objs_eq: "ys \<in> list_delta_hom n k \<Longrightarrow> xs \<in> list_delta_hom k k' \<Longrightarrow> map (\<lambda>i. xs ! i) ys \<in> list_delta_hom a b \<longleftrightarrow> a = n \<and> b = k'"
  apply (clarsimp simp: list_delta_hom_def arr_iff, safe; clarsimp?)
     apply (metis Icc_eq_Icc atLeastAtMost_upt image_set less_eq_nat.simps(1) map_nth)
  apply (erule mono_sorted)
    apply (metis atLeast0AtMost lessThan_Suc_atMost lessThan_iff mono_on_def sorted_nth_mono)
   apply (metis atLeastAtMost_iff le_imp_less_Suc nth_mem)
  by (metis atLeast0AtMost atLeastAtMost_upt atMost_iff list.set_map map_nth)

lemma sorted_list_in[simp]: "sorted_list_of_set \<langle>a\<rangle> \<in> list_delta_hom a a" by (clarsimp simp: list_delta_hom_def arr_iff)

lemma sorted_list_in'[simp]: "\<guillemotleft>sorted_list_of_set \<langle>a\<rangle> :  a \<rightarrow> a\<guillemotright>" by (clarsimp simp: list_delta_hom_def arr_iff)

lemma in_hom_iff: "xs \<in> list_delta_hom n k \<longleftrightarrow> \<guillemotleft>xs : n \<rightarrow> k\<guillemotright>"
  by (clarsimp simp: hom_of_def)

lemma sorted_list_iff[simp]: "sorted_list_of_set \<langle>a\<rangle> \<in> list_delta_hom x y \<longleftrightarrow> x = y \<and> x = a"
  apply (safe; clarsimp?)
   apply (simp add: list_delta_hom_def arr_iff)
  apply (simp add: list_delta_hom_def arr_iff)
  done

lemma carrier_iff': "x \<in> carrier {(a, b). \<exists>n k. a \<in> list_delta_hom n k \<and> (\<exists>k'. b \<in> list_delta_hom k k')} \<longleftrightarrow> (\<exists>a b. x \<in> list_delta_hom a b)"
  apply (safe; clarsimp simp: carrier_def image_iff)
   apply (elim disjE; clarsimp)
  apply (erule_tac x="sorted_list_of_set \<langle>a\<rangle>" in allE)
  apply (erule_tac x="a" in allE, clarsimp?)
  done

sublocale list_delta_cat: category map_compose list_delta_hom_set
  apply (standard; (clarsimp simp: list_delta_hom_objs_eq carrier_iff' compatible_iff sorted_list_iff[simplified in_hom_iff] magma.idems_def arrows_iff)?)
       apply (rule_tac x="sorted_list_of_set \<langle>a\<rangle>" in exI, clarsimp simp: sorted_list_iff[simplified in_hom_iff])
       apply (intro conjI)
  apply (clarsimp simp: map_compose_def)

        apply (metis atLeast0AtMost atLeast0LessThan diff_zero length_upt lessThan_Suc_atMost map_nth sorted_list_of_set_range)
       apply (clarsimp simp: arr_iff map_compose_def)

       apply (smt (verit, ccfv_SIG) Suc_le_lessD atLeast0AtMost atLeast0LessThan atLeastAtMost_upt atMost_iff card_atLeastAtMost
         card_length in_set_conv_nth lessThan_Suc_atMost lessThan_iff map_idI map_nth minus_nat.diff_0 nth_map order_le_less_trans
            sorted_list_of_set.length_sorted_key_list_of_set sorted_list_of_set_range)

      apply (rule_tac x="(sorted_list_of_set \<langle>b\<rangle>)" in exI, clarsimp simp: sorted_list_iff[simplified in_hom_iff])
      apply (intro conjI)
  apply (clarsimp simp: map_compose_def)
        apply (metis atLeast0AtMost atLeast0LessThan diff_zero length_upt lessThan_Suc_atMost map_nth sorted_list_of_set_range)
       apply (clarsimp simp: arr_iff)
       apply (rule nth_equalityI; clarsimp simp: map_compose_def)

       apply (smt (verit, ccfv_SIG)  Suc_le_lessD atLeast0AtMost atLeast0LessThan atLeastAtMost_upt atMost_iff card_atLeastAtMost
         card_length in_set_conv_nth lessThan_Suc_atMost lessThan_iff map_idI map_nth minus_nat.diff_0 nth_map order_le_less_trans
            sorted_list_of_set.length_sorted_key_list_of_set sorted_list_of_set_range)
     apply (safe; clarsimp simp: map_compose_def list_delta_hom_objs_eq[simplified in_hom_iff] )
  apply (clarsimp simp: map_compose_def)
    apply (simp add: arr_iff)
  using sorted_list_in' apply blast
  apply (rule_tac a="sorted_list_of_set \<langle>a\<rangle>" in ex1I; clarsimp simp: map_compose_def)
   apply ( intro conjI)
  using sorted_list_in' apply blast
    apply (metis atLeast0AtMost atLeast0LessThan card_lessThan lessThan_Suc_atMost map_nth sorted_list_of_set.length_sorted_key_list_of_set sorted_list_of_set_range)
   apply (intro conjI impI allI; clarsimp)
    apply (metis arr_iff atLeast0AtMost atLeast0LessThan lessThan_Suc_atMost map_nth sorted_list_of_set_range)
   apply (rule nth_equalityI; clarsimp simp: )
   apply (metis (no_types, lifting) arr_iff atLeastAtMost_upt card_atLeastAtMost in_set_conv_nth map_nth minus_nat.diff_0 nth_map nth_mem set_upt sorted_list_of_set.length_sorted_key_list_of_set sorted_list_of_set_range)
   apply (rule nth_equalityI; (clarsimp simp: )?)
  using arr_iff apply blast
  by (metis arr_iff atLeastAtMost_upt map_nth set_upt sorted_list_in' sorted_list_of_set_range)

lemma "x \<noteq> 0 \<Longrightarrow>  x = Suc (x - Suc 0)"
  by simp

lemma map_id_l: "map ((!) x) (sorted_list_of_set {..<length x}) = x"
  apply (induct x; clarsimp)
  by (smt (verit, best) Suc_leI atLeast0LessThan butlast_snoc drop_all id_take_nth_drop length_Cons lessI list.discI map_butlast map_is_Nil_conv map_nth sorted_list_of_set_range upt_Suc)

lemma map_id_r:"set x = \<langle>n\<rangle> \<Longrightarrow> map ((!) (sorted_list_of_set (set x))) x = x"
  apply (induct n arbitrary:x; clarsimp)
   apply (metis map_idI nth_Cons_0 singleton_iff)
  by (smt (verit, best) atLeast0LessThan atLeastAtMost_upt atMost_atLeast0 diff_zero in_set_conv_nth length_upt lessThan_Suc_atMost map_idI map_nth nth_map sorted_list_of_set_range)

sublocale list_delta_op: op_category map_compose list_delta_hom_set  ..

end

end