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

datatype Nat = Z | S "Nat"

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

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

fun formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

theorem property0 :
  "((formulapow (S Z) x) = (S Z))"
  oops

end


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

datatype Nat = Z | S "Nat"

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

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

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

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

end


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

datatype Nat = Z | S "Nat"

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

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

end


theory GDPR_E imports E       (*GDPR CTD Example. C. Benzmüller & X. Parent, 2019*)
begin
(*Unimportant.*) sledgehammer_params [max_facts=20,timeout=20]
(*Unimportant.*) nitpick_params [user_axioms,expect=genuine,show_all,dont_box]

datatype data = d1 | d2   (*We introduce concrete data objects d1 and d2.*)
datatype indiv = Mary | Peter (*We introduce individuals Mary and Peter.*)
consts process_lawfully::"data\<Rightarrow>\<sigma>" erase::"data\<Rightarrow>\<sigma>" is_protected_by_GDPR::"data\<Rightarrow>\<sigma>"
       belongs_to::"data\<Rightarrow>indiv\<Rightarrow>\<sigma>" is_european::"indiv=>\<sigma> " kill::"indiv\<Rightarrow>\<sigma>"

axiomatization where
(*Data belonging to Europeans is protected by the GDPR.*)
 A0: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>d. (is_european x \<^bold>\<and> belongs_to d x) \<^bold>\<rightarrow> is_protected_by_GDPR d\<rfloor>" and
(*Data d1 is belonging to the European Peter.*)
 F1: "\<lfloor>belongs_to d1 Peter \<^bold>\<and> is_european Peter\<rfloor>" and

(*It is an obligation to process data lawfully.*)
 A1: "\<lfloor>\<^bold>\<forall>d. \<circle><process_lawfully d | is_protected_by_GDPR d>\<rfloor>"  and
(*If data was not processed lawfully, then it is an obligation to erase the data.*)
 A2: "\<lfloor>\<^bold>\<forall>d. \<circle><erase d | is_protected_by_GDPR d  \<^bold>\<and> \<^bold>\<not>process_lawfully d>\<rfloor>" and
(*Implicit: It is an obligation to keep the data if it was processed lawfully.*)
 Implicit: "\<lfloor>\<^bold>\<forall>d. \<circle><\<^bold>\<not>erase d | is_protected_by_GDPR d \<^bold>\<and> process_lawfully d>\<rfloor>" and
(*Given a situation where data is processed unlawfully.*)
 Situation: "\<lfloor>\<^bold>\<not>process_lawfully d1\<rfloor>\<^sub>l"

(***Some Experiments***)
 lemma True nitpick [satisfy] oops (*Consistency-check: Nitpick finds a model.*)
 lemma False sledgehammer oops (*Inconsistency-check: Can Falsum be derived? No.*)

 lemma "\<lfloor>\<^bold>\<circle><erase d1>\<rfloor>\<^sub>l" nitpick oops (*Should the data be erased? — No. Countermodel by Nitpick.*)
 lemma "\<lfloor>\<^bold>\<circle><\<^bold>\<not>erase d1>\<rfloor>\<^sub>l" sledgehammer using A0 A1 F1 Implicit by blast (*Should the data be kept? — Yes.*)
 lemma "\<lfloor>\<^bold>\<circle><kill Mary>\<rfloor>\<^sub>l" nitpick oops (*Should Mary be killed? — No. Countermodel by Nitpick.*)
end


(*  Title:      HOL/Proofs/Lambda/ParRed.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen

Properties of => and "cd", in particular the diamond property of => and
confluence of beta.
*)

section \<open>Parallel reduction and a complete developments\<close>

theory ParRed imports Lambda Commutation begin

subsection \<open>Parallel reduction\<close>

inductive par_beta :: "[dB, dB] => bool"  (infixl "=>" 50)
  where
    var [simp, intro!]: "Var n => Var n"
  | abs [simp, intro!]: "s => t ==> Abs s => Abs t"
  | app [simp, intro!]: "[| s => s'; t => t' |] ==> s \<degree> t => s' \<degree> t'"
  | beta [simp, intro!]: "[| s => s'; t => t' |] ==> (Abs s) \<degree> t => s'[t'/0]"

inductive_cases par_beta_cases [elim!]:
  "Var n => t"
  "Abs s => Abs t"
  "(Abs s) \<degree> t => u"
  "s \<degree> t => u"
  "Abs s => t"

subsection \<open>Inclusions\<close>

text \<open>\<open>beta \<subseteq> par_beta \<subseteq> beta\<^sup>*\<close> \medskip\<close>

lemma par_beta_varL [simp]:
    "(Var n => t) = (t = Var n)"
  by blast

lemma par_beta_refl [simp]: "t => t"  (* par_beta_refl [intro!] causes search to blow up *)
  by (induct t) simp_all

lemma beta_subset_par_beta: "beta <= par_beta"
  apply (rule predicate2I)
  apply (erule beta.induct)
     apply (blast intro!: par_beta_refl)+
  done

lemma par_beta_subset_beta: "par_beta \<le> beta\<^sup>*\<^sup>*"
  apply (rule predicate2I)
  apply (erule par_beta.induct)
     apply blast
    apply (blast del: rtranclp.rtrancl_refl intro: rtranclp.rtrancl_into_rtrancl)+
      \<comment> \<open>@{thm[source] rtrancl_refl} complicates the proof by increasing the branching factor\<close>
  done

subsection \<open>Misc properties of \<open>par_beta\<close>\<close>

lemma par_beta_lift [simp]:
    "t => t' \<Longrightarrow> lift t n => lift t' n"
  by (induct t arbitrary: t' n) fastforce+

lemma par_beta_subst:
    "s => s' \<Longrightarrow> t => t' \<Longrightarrow> t[s/n] => t'[s'/n]"
  apply (induct t arbitrary: s s' t' n)
    apply (simp add: subst_Var)
   apply (erule par_beta_cases)
    apply simp
   apply (simp add: subst_subst [symmetric])
   apply (fastforce intro!: par_beta_lift)
  apply fastforce
  done

subsection \<open>Confluence (directly)\<close>

lemma diamond_par_beta: "diamond par_beta"
  apply (unfold diamond_def commute_def square_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule par_beta.induct)
     apply (blast intro!: par_beta_subst)+
  done

subsection \<open>Complete developments\<close>

fun
  cd :: "dB => dB"
where
  "cd (Var n) = Var n"
| "cd (Var n \<degree> t) = Var n \<degree> cd t"
| "cd ((s1 \<degree> s2) \<degree> t) = cd (s1 \<degree> s2) \<degree> cd t"
| "cd (Abs u \<degree> t) = (cd u)[cd t/0]"
| "cd (Abs s) = Abs (cd s)"

lemma par_beta_cd: "s => t \<Longrightarrow> t => cd s"
  apply (induct s arbitrary: t rule: cd.induct)
      apply auto
  apply (fast intro!: par_beta_subst)
  done

subsection \<open>Confluence (via complete developments)\<close>

lemma diamond_par_beta2: "diamond par_beta"
  apply (unfold diamond_def commute_def square_def)
  apply (blast intro: par_beta_cd)
  done

theorem beta_confluent: "confluent beta"
  apply (rule diamond_par_beta2 diamond_to_confluence
    par_beta_subset_beta beta_subset_par_beta)+
  done

end


theory Remove_And_Copy
  imports "HOL-IMP.Sem_Equiv" "HOL-IMP.Vars"
begin

notation Map.empty ("empty")

text {*
\exercise\label{exs:remove}
This exercise builds infrastructure for \autoref{exs:acopy}, where we
will have to manipulate partial maps from variable names to variable names.
*}
type_synonym tab = "vname \<Rightarrow> vname option"

text {*
  In addition to the function @{text merge} from theory @{text Fold},
  implement two functions @{text remove} and @{text remove_all} that
  remove one variable name from the range of a map, and a set of variable
  names from the domain and range of a map.
*}

definition
  merge :: "tab \<Rightarrow> tab \<Rightarrow> tab" where
  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"

definition remove :: "vname \<Rightarrow> tab \<Rightarrow> tab"  where
(* your definition/proof here *)

definition remove_all :: "vname set \<Rightarrow> tab \<Rightarrow> tab"  where
(* your definition/proof here *)

text {*
  Prove the following lemmas.
*}

lemma "ran (remove x t) = ran t - {x}"
(* your definition/proof here *)

lemma "ran (remove_all S t) \<subseteq> -S"
(* your definition/proof here *)

lemma "dom (remove_all S t) \<subseteq> -S"
(* your definition/proof here *)

lemma remove_all_update[simp]:
"remove_all {x} (t (x:= y)) = remove_all {x} t"
(* your definition/proof here *)

lemma remove_all_remove[simp]:
"remove_all {x} (remove x t) = remove_all {x} t"
(* your definition/proof here *)

lemma remove_all_Un[simp]:
"remove_all A (remove_all B t) = remove_all (A \<union> B) t"
(* your definition/proof here *)

lemma merge_remove_all:
  assumes "remove_all S t1 = remove_all S t"
  assumes "remove_all S t2 = remove_all S t"
  shows "remove_all S (merge t1 t2) = remove_all S t"
(* your definition/proof here *)

text {*
  \endexercise

  \exercise\label{exs:acopy}
  This is a more challenging exercise.
  Define and prove correct \emph{copy propagation}. Copy propagation is
similar to constant folding, but propagates the right-hand side of assignments
if these right-hand sides are just variables. For instance, the program
\texttt{x := y; z := x + z} will be transformed into
\texttt{x := y; z := y + z}.
The assignment \texttt{x := y} can then be eliminated in a liveness
analysis. Copy propagation is useful for cleaning up after other optimisation
phases.

  To do this, take the definitions for constant folding from theory
  @{text Fold} and adjust
  them to do copy propagation instead (without constant folding).
  Use the functions from \autoref{exs:remove} in your definition.
  The general proof idea and structure of constant folding remains
  applicable. Adjust it according to your new definitions.
*}

primrec copy :: "com \<Rightarrow> tab \<Rightarrow> com" where
(* your definition/proof here *)

value "copy (''x'' ::= V ''y'';; ''z'' ::= Plus (V ''x'') (V ''z'')) Map.empty"

lemma approx_merge:
  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
  by (fastforce simp: merge_def approx_def)

lemma approx_map_le:
  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
  by (clarsimp simp: approx_def map_le_def dom_def)

theorem "copy c Map.empty \<sim> c"
(* your definition/proof here *)

text {* \endexercise *}

end


(*  Title:      HOL/Induct/Term.thy
    Author:     Stefan Berghofer,  TU Muenchen
*)

section {* Terms over a given alphabet *}

theory Term
imports Main
begin

datatype ('a, 'b) "term" =
    Var 'a
  | App 'b "('a, 'b) term list"

text {* \medskip Substitution function on terms *}

primrec subst_term :: "('a => ('a, 'b) term) => ('a, 'b) term => ('a, 'b) term"
  and subst_term_list :: "('a => ('a, 'b) term) => ('a, 'b) term list => ('a, 'b) term list"
where
  "subst_term f (Var a) = f a"
| "subst_term f (App b ts) = App b (subst_term_list f ts)"
| "subst_term_list f [] = []"
| "subst_term_list f (t # ts) = subst_term f t # subst_term_list f ts"

text {* \medskip A simple theorem about composition of substitutions *}

lemma subst_comp:
  "subst_term (subst_term f1 \<circ> f2) t =
    subst_term f1 (subst_term f2 t)"
and "subst_term_list (subst_term f1 \<circ> f2) ts =
    subst_term_list f1 (subst_term_list f2 ts)"
  by (induct t and ts rule: subst_term.induct subst_term_list.induct) simp_all

text {* \medskip Alternative induction rule *}

lemma
  assumes var: "!!v. P (Var v)"
    and app: "!!f ts. (\<forall>t \<in> set ts. P t) ==> P (App f ts)"
  shows term_induct2: "P t"
    and "\<forall>t \<in> set ts. P t"
  apply (induct t and ts rule: subst_term.induct subst_term_list.induct)
     apply (rule var)
    apply (rule app)
    apply assumption
   apply simp_all
  done

end


(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Probability mass functions\<close>

theory Applicative_PMF imports
  Applicative
  "HOL-Probability.Probability"
  "HOL-Library.Adhoc_Overloading"
begin

abbreviation (input) pure_pmf :: "'a \<Rightarrow> 'a pmf"
where "pure_pmf \<equiv> return_pmf"

definition ap_pmf :: "('a \<Rightarrow> 'b) pmf \<Rightarrow> 'a pmf \<Rightarrow> 'b pmf"
where "ap_pmf f x = map_pmf (\<lambda>(f, x). f x) (pair_pmf f x)"

adhoc_overloading Applicative.ap ap_pmf

context includes applicative_syntax
begin

lemma ap_pmf_id: "pure_pmf (\<lambda>x. x) \<diamondop> x = x"
by(simp add: ap_pmf_def pair_return_pmf1 pmf.map_comp o_def)

lemma ap_pmf_comp: "pure_pmf (\<circ>) \<diamondop> u \<diamondop> v \<diamondop> w = u \<diamondop> (v \<diamondop> w)"
by(simp add: ap_pmf_def pair_return_pmf1 pair_map_pmf1 pair_map_pmf2 pmf.map_comp o_def split_def pair_pair_pmf)

lemma ap_pmf_homo: "pure_pmf f \<diamondop> pure_pmf x = pure_pmf (f x)"
by(simp add: ap_pmf_def pair_return_pmf1)

lemma ap_pmf_interchange: "u \<diamondop> pure_pmf x = pure_pmf (\<lambda>f. f x) \<diamondop> u"
by(simp add: ap_pmf_def pair_return_pmf1 pair_return_pmf2 pmf.map_comp o_def)

lemma ap_pmf_K: "return_pmf (\<lambda>x _. x) \<diamondop> x \<diamondop> y = x"
by(simp add: ap_pmf_def pair_map_pmf1 pmf.map_comp pair_return_pmf1 o_def split_def map_fst_pair_pmf)

lemma ap_pmf_C: "return_pmf (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
apply(simp add: ap_pmf_def pair_map_pmf1 pmf.map_comp pair_return_pmf1 pair_pair_pmf o_def split_def)
apply(subst (2) pair_commute_pmf)
apply(simp add: pair_map_pmf2 pmf.map_comp o_def split_def)
done

lemma ap_pmf_transfer[transfer_rule]:
  "rel_fun (rel_pmf (rel_fun A B)) (rel_fun (rel_pmf A) (rel_pmf B)) ap_pmf ap_pmf"
unfolding ap_pmf_def[abs_def] pair_pmf_def
by transfer_prover

applicative pmf (C, K)
for
  pure: pure_pmf
  ap: ap_pmf
  rel: rel_pmf
  set: set_pmf
proof -
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "rel_fun R (rel_pmf R) pure_pmf pure_pmf" by transfer_prover
next
  fix R and f :: "('a \<Rightarrow> 'b) pmf" and g :: "('a \<Rightarrow> 'c) pmf" and x
  assume [transfer_rule]: "rel_pmf (rel_fun (eq_on (set_pmf x)) R) f g"
  have [transfer_rule]: "rel_pmf (eq_on (set_pmf x)) x x" by (simp add: pmf.rel_refl_strong)
  show "rel_pmf R (ap_pmf f x) (ap_pmf g x)" by transfer_prover
qed(rule ap_pmf_comp[unfolded o_def[abs_def]] ap_pmf_homo ap_pmf_C ap_pmf_K)+

end

end


(*  File:       Pairwise_Majority_Rule.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Pairwise Majority Rule\<close>

theory Pairwise_Majority_Rule
  imports "Compositional_Structures/Basic_Modules/Condorcet_Module"
          "Compositional_Structures/Defer_One_Loop_Composition"
begin

text
\<open>This is the pairwise majority rule, a voting rule that implements the
Condorcet criterion, i.e., it elects the Condorcet winner if it exists,
otherwise a tie remains between all alternatives.\<close>

subsection \<open>Definition\<close>

fun pairwise_majority_rule :: "'a Electoral_Module" where
  "pairwise_majority_rule A p = elector condorcet A p"

fun condorcet' :: "'a Electoral_Module" where
"condorcet' A p =
  ((min_eliminator condorcet_score) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) A p"

fun pairwise_majority_rule' :: "'a Electoral_Module" where
"pairwise_majority_rule' A p = iterelect condorcet' A p"

subsection \<open>Condorcet Consistency Property\<close>

theorem condorcet_condorcet: "condorcet_consistency pairwise_majority_rule"
proof -
  have
    "condorcet_consistency (elector condorcet)"
    using condorcet_is_dcc dcc_imp_cc_elector
    by metis
  thus ?thesis
    using condorcet_consistency2 electoral_module_def
          pairwise_majority_rule.simps
    by metis
qed

end


(*
  Title: The Quantaloid of Kleisli Arrows
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>The Quantaloid of Kleisli Arrows\<close>

theory Kleisli_Quantaloid

imports Kleisli_Transformers
begin

text \<open>This component formalises the quantalic structure of Kleisli arrows or state transformers, that is,
the homset of the Kleisli category. Of course, by the previous isomorphisms, this is reflected at least
partially in the Eilenberg-Moore algebras, via the comparison functor. The main result is that Kleisli arrows
form a quantaloid, hence essentially a typed quantale. Some emphasis is on the star. This component thus complements
that in which the quantaloid structure of Sup- and Inf-preserving transformers has been formalised.\<close>

text \<open>The first set of lemmas shows that Kleisli arrows form a typed dioid, that is, a typed idempotent semiring.\<close>

lemma ksup_assoc: "((f::'a \<Rightarrow> 'b set) \<squnion> g) \<squnion> h = f \<squnion> (g \<squnion> h)"
  unfolding sup.assoc by simp

lemma ksup_comm: "(f::'a => 'b set) \<squnion> g = g \<squnion> f"
  by (simp add: sup.commute)

lemma ksup_idem [simp]: "(f::'a \<Rightarrow> 'b set) \<squnion> f = f"
  by simp

lemma kcomp_distl: "f \<circ>\<^sub>K (g \<squnion> h) = (f \<circ>\<^sub>K g) \<squnion> (f \<circ>\<^sub>K h)"
  unfolding kcomp_klift fun_eq_iff comp_def sup_fun_def by (simp add: UN_Un_distrib klift_prop)

lemma kcomp_distr: "(f \<squnion> g) \<circ>\<^sub>K h = (f \<circ>\<^sub>K h) \<squnion> (g \<circ>\<^sub>K h)"
  by (simp add: kcomp_klift fun_eq_iff klift_def)

lemma ksup_zerol [simp]: "\<zeta> \<squnion> f = f"
  by force

lemma ksup_annil [simp]: "\<zeta> \<circ>\<^sub>K f = \<zeta>"
  by (force simp: kcomp_klift klift_def)

lemma ksup_annir [simp]: "f \<circ>\<^sub>K \<zeta> = \<zeta>"
  by (force simp: kcomp_klift klift_def)

text \<open>Associativity of Kleisli composition has already been proved.\<close>

text \<open>The next laws establish typed quantales --- or quantaloids.\<close>

lemma kSup_distl: "f \<circ>\<^sub>K (\<Squnion>G) = (\<Squnion>g \<in> G. f \<circ>\<^sub>K g)"
proof-
  have "f \<circ>\<^sub>K (\<Squnion>G) = ((klift \<circ> Sup) G) \<circ> f"
    by (simp add: kcomp_klift)
  also have "... = (\<Squnion>g \<in> G. (klift g)) \<circ> f"
    by (simp add: fbd_Sup_pres fun_eq_iff)
  also have "... = (\<Squnion>g \<in> G. (klift g) \<circ> f)"
    by auto
  finally show ?thesis
    by (simp add: kcomp_klift)
qed

lemma kSup_distr: "(\<Squnion>F) \<circ>\<^sub>K g = (\<Squnion>f \<in> F. f \<circ>\<^sub>K g)"
  unfolding kcomp_klift fun_eq_iff comp_def by (simp add: klift_prop)

lemma kcomp_isol: "f \<le> g \<Longrightarrow> h \<circ>\<^sub>K f \<le> h \<circ>\<^sub>K g"
  by (force simp: kcomp_klift le_fun_def klift_def)

lemma kcomp_isor: "f \<le> g \<Longrightarrow> f \<circ>\<^sub>K h \<le> g \<circ>\<^sub>K h"
  by (force simp: kcomp_klift le_fun_def klift_def)

subsection \<open>Kleene Star\<close>

text \<open>The Kleene star can be defined in any quantale or quantaloid by iteration. For Kleisli arrows,
laws for the star can be obtained via the isomorphism to binary relations, where the star is the reflexive-transitive
closure operation.\<close>

abbreviation "kpower \<equiv> kmon.power"

lemma r2f_pow: "\<F> (R ^^ i) = kpower (\<F> R) i"
  by (induct i, simp, metis power.power.power_Suc r2f_comp_pres relpow.simps(2) relpow_commute)

lemma f2r_kpower: "\<R> (kpower f i) = (\<R> f) ^^ i"
  by (induct i, simp, metis f2r2f_inv2 pointfree_idE r2f2r_inv1 r2f_pow)

definition "kstar f = (\<Squnion>i. kpower f i)"

lemma r2f_rtrancl_hom: "\<F> (rtrancl R) = kstar (\<F> R)"
proof-
  have "\<F> (rtrancl R) = \<F> (\<Union>i. R ^^ i)"
    by (simp add: full_SetCompr_eq rtrancl_is_UN_relpow)
  also have "... = (\<Squnion>i. kpower (\<F> R) i)"
    by (auto simp: r2f_Sup_pres_var r2f_pow)
  finally show ?thesis
    by (simp add: kstar_def)
qed

lemma r2f_rtrancl_hom_var: "\<F> \<circ> rtrancl = kstar \<circ> \<F>"
  by standard (simp add: r2f_rtrancl_hom)

lemma f2r_kstar_hom: "\<R> (kstar f) = rtrancl (\<R> f)"
  by (metis r2f_f2r_galois r2f_rtrancl_hom)

lemma f2r_kstar_hom_var: "\<R> \<circ> kstar = rtrancl \<circ> \<R>"
  by standard (simp add: f2r_kstar_hom)

lemma kstar_unfoldl_eq: "\<eta> \<squnion> f \<circ>\<^sub>K kstar f = kstar f"
proof -
  have "\<R> (kstar f) = (\<R> \<eta>) \<union> (\<R> f)\<^sup>* ; \<R> f"
    using f2r_kstar_hom rtrancl_unfold
    by (metis f2r_eta_pres)
  thus ?thesis
    by (metis f2r_kcomp_pres f2r_kstar_hom f2r_sup_pres r2f_inj_iff r_comp_rtrancl_eq)
qed

lemma kstar_unfoldl: "\<eta> \<squnion> f \<circ>\<^sub>K  kstar f \<le> kstar f"
  by (simp add: kstar_unfoldl_eq)

lemma kstar_unfoldr_eq: "\<eta> \<squnion> (kstar f) \<circ>\<^sub>K f = kstar f"
  by (metis (no_types) f2r2f_inv2 f2r_kcomp_pres f2r_kstar_hom kstar_unfoldl_eq pointfree_idE r_comp_rtrancl_eq)

lemma kstar_unfoldr: "\<eta> \<squnion> (kstar f) \<circ>\<^sub>K f \<le> kstar f"
  by (simp add: kstar_unfoldr_eq)

text \<open>Relational induction laws seem to be missing in Isabelle Main. So I derive functional laws directly.\<close>

lemma kpower_inductl: "f \<circ>\<^sub>K g \<le> g \<Longrightarrow> kpower f i \<circ>\<^sub>K g \<le> g"
  by (induct i, simp_all add: kcomp_assoc kcomp_isol order_subst2)

lemma kpower_inductl_var: "h \<squnion> f \<circ>\<^sub>K g \<le> g \<Longrightarrow> kpower f i \<circ>\<^sub>K h \<le> g"
proof -
  assume h1: "h \<squnion> f \<circ>\<^sub>K g \<le> g"
  then have h2: "f \<circ>\<^sub>K g \<le> g"
    using le_sup_iff by blast
  have "h \<le> g"
    using h1 by simp
  then show ?thesis
    using h2 kcomp_isol kpower_inductl order_trans by blast
qed

lemma kstar_inductl: "h \<squnion> f \<circ>\<^sub>K g \<le> g \<Longrightarrow> kstar f \<circ>\<^sub>K h \<le> g"
  apply (simp add: kstar_def kSup_distr, rule Sup_least)
  using kpower_inductl_var by fastforce

lemma kpower_inductr: "g \<circ>\<^sub>K f \<le> g \<Longrightarrow> g \<circ>\<^sub>K kpower f i \<le> g"
  apply (induct i, simp_all)
  by (metis (mono_tags, lifting) dual_order.trans kcomp_assoc kcomp_isor)

lemma kpower_inductr_var: "h \<squnion> g \<circ>\<^sub>K f \<le> g \<Longrightarrow> h \<circ>\<^sub>K kpower f i \<le> g"
  by (metis (no_types) dual_order.trans kcomp_isor kpower_inductr le_sup_iff)

lemma kstar_inductr: "h \<squnion> g \<circ>\<^sub>K f \<le> g \<Longrightarrow> h \<circ>\<^sub>K kstar f \<le> g"
  apply (simp add: kstar_def kSup_distl, rule Sup_least)
  using kpower_inductr_var by fastforce

lemma kpower_prop: "f \<le> \<eta> \<Longrightarrow> kpower f i \<le> \<eta>"
  by (metis kcomp_idl kpower_inductr)

lemma kstar_prop: "f \<le> \<eta> \<Longrightarrow> kstar f \<le> \<eta>"
  by (simp add: SUP_le_iff kpower_prop kstar_def)

subsection \<open>Antidomain\<close>

text \<open>Next I define an antidomain operation and prove the axioms of antidomain semirings~\cite{GomesGHSW16,DesharnaisS11}.\<close>

definition "kad f = (\<lambda>x. if (f x = {}) then {x} else {})"

definition "ad_rel R = {(x,x) |x. \<not>(\<exists>y. (x,y) \<in> R)}"

lemma f2r_ad_fun_hom: "\<R> (kad f) = ad_rel (\<R> f)"
  apply (simp add: kad_def ad_rel_def f2r_def, safe)
  by simp_all (meson empty_iff singletonD)

lemma f2r_ad_fun_hom_var:"\<R> \<circ> kad = ad_rel \<circ> \<R>"
  by standard (simp add: f2r_ad_fun_hom)

lemma r2f_ad_rel_hom: "\<F> (ad_rel R) = kad (\<F> R)"
  by (force simp add: kad_def ad_rel_def r2f_def fun_eq_iff)

lemma r2f_ad_rel_hom_var:"\<F> \<circ> ad_rel = kad \<circ> \<F>"
  by standard (simp add: r2f_ad_rel_hom)

lemma ad_fun_as1 [simp]: "(kad f) \<circ>\<^sub>K f = \<zeta>"
  by (simp add: kad_def kcomp_def fun_eq_iff)

lemma ad_fun_as2 [simp]: "kad (f \<circ>\<^sub>K g) \<squnion> kad (f \<circ>\<^sub>K kad (kad g)) = kad (f \<circ>\<^sub>K kad (kad g))"
  by (force simp: kad_def kcomp_def fun_eq_iff)

lemma ad_fun_as3 [simp]: "kad (kad f) \<squnion> kad f = \<eta>"
  by (simp add: kad_def fun_eq_iff)

definition "set2fun X = (\<lambda>x. if (x \<in> X) then {x} else {})"

definition "p2fun = set2fun \<circ> Collect"

lemma ffb_ad_fun: "fb\<^sub>\<F> f X = {x. (kad (f \<circ>\<^sub>K kad (set2fun X))) x \<noteq> {}}"
  unfolding ffb_prop_var klift_def kop_def fun_eq_iff comp_def f2r_def r2f_def converse_def kad_def kcomp_def set2fun_def
  by auto

lemma ffb_ad_fun2: "set2fun (fb\<^sub>\<F> f X) = kad (f \<circ>\<^sub>K kad (set2fun X))"
  by standard (subst ffb_ad_fun, subst set2fun_def, simp add: kad_def)

text \<open>The final statements check that the relational forward diamond is consistent with the Kleene-algebraic definition.\<close>

lemma fb_ad_rel: "fb\<^sub>\<R> R X = Domain (ad_rel (R ; ad_rel (Id_on X)))"
  unfolding rfb_def ffb_prop_var klift_def comp_def r2f_def kop_def f2r_def converse_def Domain_def Id_on_def ad_rel_def
  by auto

lemma fb_ad_rel2: "Id_on (fb\<^sub>\<R> R X) = ad_rel (R ; ad_rel (Id_on X))"
  unfolding rfb_def ffb_prop_var klift_def comp_def r2f_def kop_def f2r_def converse_def Domain_def Id_on_def ad_rel_def
  by auto

end


(*  Title:      HOL/HOLCF/Pcpo.thy
    Author:     Franz Regensburger
*)

section {* Classes cpo and pcpo *}

theory Pcpo
imports Porder
begin

subsection {* Complete partial orders *}

text {* The class cpo of chain complete partial orders *}

class cpo = po +
  assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
begin

text {* in cpo's everthing equal to THE lub has lub properties for every chain *}

lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
  by (fast dest: cpo elim: is_lub_lub)

lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
  by (blast dest: cpo intro: is_lub_lub)

text {* Properties of the lub *}

lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
  by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])

lemma is_lub_thelub:
  "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
  by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])

lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
  by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)

lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
  by (simp add: lub_below_iff)

lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
  by (erule below_trans, erule is_ub_thelub)

lemma lub_range_mono:
  "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
apply (erule lub_below)
apply (subgoal_tac "\<exists>j. X i = Y j")
apply  clarsimp
apply  (erule is_ub_thelub)
apply auto
done

lemma lub_range_shift:
  "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
apply (rule below_antisym)
apply (rule lub_range_mono)
apply    fast
apply   assumption
apply (erule chain_shift)
apply (rule lub_below)
apply assumption
apply (rule_tac i="i" in below_lub)
apply (erule chain_shift)
apply (erule chain_mono)
apply (rule le_add1)
done

lemma maxinch_is_thelub:
  "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
apply (rule iffI)
apply (fast intro!: lub_eqI lub_finch1)
apply (unfold max_in_chain_def)
apply (safe intro!: below_antisym)
apply (fast elim!: chain_mono)
apply (drule sym)
apply (force elim!: is_ub_thelub)
done

text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}

lemma lub_mono:
  "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
by (fast elim: lub_below below_lub)

text {* the = relation between two chains is preserved by their lubs *}

lemma lub_eq:
  "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
  by simp

lemma ch2ch_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
apply (rule chainI)
apply (rule lub_mono [OF 2 2])
apply (rule chainE [OF 1])
done

lemma diag_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
proof (rule below_antisym)
  have 3: "chain (\<lambda>i. Y i i)"
    apply (rule chainI)
    apply (rule below_trans)
    apply (rule chainE [OF 1])
    apply (rule chainE [OF 2])
    done
  have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
    by (rule ch2ch_lub [OF 1 2])
  show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
    apply (rule lub_below [OF 4])
    apply (rule lub_below [OF 2])
    apply (rule below_lub [OF 3])
    apply (rule below_trans)
    apply (rule chain_mono [OF 1 max.cobounded1])
    apply (rule chain_mono [OF 2 max.cobounded2])
    done
  show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
    apply (rule lub_mono [OF 3 4])
    apply (rule is_ub_thelub [OF 2])
    done
qed

lemma ex_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
  by (simp add: diag_lub 1 2)

end

subsection {* Pointed cpos *}

text {* The class pcpo of pointed cpos *}

class pcpo = cpo +
  assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
begin

definition bottom :: "'a"
  where "bottom = (THE x. \<forall>y. x \<sqsubseteq> y)"

notation (xsymbols)
  bottom ("\<bottom>")

lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
unfolding bottom_def
apply (rule the1I2)
apply (rule ex_ex1I)
apply (rule least)
apply (blast intro: below_antisym)
apply simp
done

end

text {* Old "UU" syntax: *}

syntax UU :: logic

translations "UU" => "CONST bottom"

text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}

setup {*
  Reorient_Proc.add
    (fn Const(@{const_name bottom}, _) => true | _ => false)
*}

simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc

text {* useful lemmas about @{term \<bottom>} *}

lemma below_bottom_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
by (simp add: po_eq_conv)

lemma eq_bottom_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
by simp

lemma bottomI: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
by (subst eq_bottom_iff)

lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
by (simp only: eq_bottom_iff lub_below_iff)

subsection {* Chain-finite and flat cpos *}

text {* further useful classes for HOLCF domains *}

class chfin = po +
  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
begin

subclass cpo
apply default
apply (frule chfin)
apply (blast intro: lub_finch1)
done

lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
  by (simp add: chfin finite_chain_def)

end

class flat = pcpo +
  assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
begin

subclass chfin
apply default
apply (unfold max_in_chain_def)
apply (case_tac "\<forall>i. Y i = \<bottom>")
apply simp
apply simp
apply (erule exE)
apply (rule_tac x="i" in exI)
apply clarify
apply (blast dest: chain_mono ax_flat)
done

lemma flat_below_iff:
  shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
  by (safe dest!: ax_flat)

lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
  by (safe dest!: ax_flat)

end

subsection {* Discrete cpos *}

class discrete_cpo = below +
  assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
begin

subclass po
proof qed simp_all

text {* In a discrete cpo, every chain is constant *}

lemma discrete_chain_const:
  assumes S: "chain S"
  shows "\<exists>x. S = (\<lambda>i. x)"
proof (intro exI ext)
  fix i :: nat
  have "S 0 \<sqsubseteq> S i" using S le0 by (rule chain_mono)
  hence "S 0 = S i" by simp
  thus "S i = S 0" by (rule sym)
qed

subclass chfin
proof
  fix S :: "nat \<Rightarrow> 'a"
  assume S: "chain S"
  hence "\<exists>x. S = (\<lambda>i. x)" by (rule discrete_chain_const)
  hence "max_in_chain 0 S"
    unfolding max_in_chain_def by auto
  thus "\<exists>i. max_in_chain i S" ..
qed

end

end


(*  Title:      HOL/Library/Sorting_Algorithms.thy
    Author:     Florian Haftmann, TU Muenchen
*)

theory Sorting_Algorithms
  imports MainRLT Multiset Comparator
begin

section \<open>Stably sorted lists\<close>

abbreviation (input) stable_segment :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "stable_segment cmp x \<equiv> filter (\<lambda>y. compare cmp x y = Equiv)"

fun sorted :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> bool"
  where sorted_Nil: "sorted cmp [] \<longleftrightarrow> True"
  | sorted_single: "sorted cmp [x] \<longleftrightarrow> True"
  | sorted_rec: "sorted cmp (y # x # xs) \<longleftrightarrow> compare cmp y x \<noteq> Greater \<and> sorted cmp (x # xs)"

lemma sorted_ConsI:
  "sorted cmp (x # xs)" if "sorted cmp xs"
    and "\<And>y ys. xs = y # ys \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (cases xs) simp_all

lemma sorted_Cons_imp_sorted:
  "sorted cmp xs" if "sorted cmp (x # xs)"
  using that by (cases xs) simp_all

lemma sorted_Cons_imp_not_less:
  "compare cmp y x \<noteq> Greater" if "sorted cmp (y # xs)"
    and "x \<in> set xs"
  using that by (induction xs arbitrary: y) (auto dest: compare.trans_not_greater)

lemma sorted_induct [consumes 1, case_names Nil Cons, induct pred: sorted]:
  "P xs" if "sorted cmp xs" and "P []"
    and *: "\<And>x xs. sorted cmp xs \<Longrightarrow> P xs
      \<Longrightarrow> (\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater) \<Longrightarrow> P (x # xs)"
using \<open>sorted cmp xs\<close> proof (induction xs)
  case Nil
  show ?case
    by (rule \<open>P []\<close>)
next
  case (Cons x xs)
  from \<open>sorted cmp (x # xs)\<close> have "sorted cmp xs"
    by (cases xs) simp_all
  moreover have "P xs" using \<open>sorted cmp xs\<close>
    by (rule Cons.IH)
  moreover have "compare cmp x y \<noteq> Greater" if "y \<in> set xs" for y
  using that \<open>sorted cmp (x # xs)\<close> proof (induction xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons z zs)
    then show ?case
    proof (cases zs)
      case Nil
      with Cons.prems show ?thesis
        by simp
    next
      case (Cons w ws)
      with Cons.prems have "compare cmp z w \<noteq> Greater" "compare cmp x z \<noteq> Greater"
        by auto
      then have "compare cmp x w \<noteq> Greater"
        by (auto dest: compare.trans_not_greater)
      with Cons show ?thesis
        using Cons.prems Cons.IH by auto
    qed
  qed
  ultimately show ?case
    by (rule *)
qed

lemma sorted_induct_remove1 [consumes 1, case_names Nil minimum]:
  "P xs" if "sorted cmp xs" and "P []"
    and *: "\<And>x xs. sorted cmp xs \<Longrightarrow> P (remove1 x xs)
      \<Longrightarrow> x \<in> set xs \<Longrightarrow> hd (stable_segment cmp x xs) = x \<Longrightarrow> (\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater)
    \<Longrightarrow> P xs"
using \<open>sorted cmp xs\<close> proof (induction xs)
  case Nil
  show ?case
    by (rule \<open>P []\<close>)
next
  case (Cons x xs)
  then have "sorted cmp (x # xs)"
    by (simp add: sorted_ConsI)
  moreover note Cons.IH
  moreover have "\<And>y. compare cmp x y = Greater \<Longrightarrow> y \<in> set xs \<Longrightarrow> False"
    using Cons.hyps by simp
  ultimately show ?case
    by (auto intro!: * [of "x # xs" x]) blast
qed

lemma sorted_remove1:
  "sorted cmp (remove1 x xs)" if "sorted cmp xs"
proof (cases "x \<in> set xs")
  case False
  with that show ?thesis
    by (simp add: remove1_idem)
next
  case True
  with that show ?thesis proof (induction xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons y ys)
    show ?case proof (cases "x = y")
      case True
      with Cons.hyps show ?thesis
        by simp
    next
      case False
      then have "sorted cmp (remove1 x ys)"
        using Cons.IH Cons.prems by auto
      then have "sorted cmp (y # remove1 x ys)"
      proof (rule sorted_ConsI)
        fix z zs
        assume "remove1 x ys = z # zs"
        with \<open>x \<noteq> y\<close> have "z \<in> set ys"
          using notin_set_remove1 [of z ys x] by auto
        then show "compare cmp y z \<noteq> Greater"
          by (rule Cons.hyps(2))
      qed
      with False show ?thesis
        by simp
    qed
  qed
qed

lemma sorted_stable_segment:
  "sorted cmp (stable_segment cmp x xs)"
proof (induction xs)
  case Nil
  show ?case
    by simp
next
  case (Cons y ys)
  then show ?case
    by (auto intro!: sorted_ConsI simp add: filter_eq_Cons_iff compare.sym)
      (auto dest: compare.trans_equiv simp add: compare.sym compare.greater_iff_sym_less)

qed

primrec insort :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "insort cmp y [] = [y]"
  | "insort cmp y (x # xs) = (if compare cmp y x \<noteq> Greater
       then y # x # xs
       else x # insort cmp y xs)"

lemma mset_insort [simp]:
  "mset (insort cmp x xs) = add_mset x (mset xs)"
  by (induction xs) simp_all

lemma length_insort [simp]:
  "length (insort cmp x xs) = Suc (length xs)"
  by (induction xs) simp_all

lemma sorted_insort:
  "sorted cmp (insort cmp x xs)" if "sorted cmp xs"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then show ?case by (cases ys)
    (auto, simp_all add: compare.greater_iff_sym_less)
qed

lemma stable_insort_equiv:
  "stable_segment cmp y (insort cmp x xs) = x # stable_segment cmp y xs"
    if "compare cmp y x = Equiv"
proof (induction xs)
  case Nil
  from that show ?case
    by simp
next
  case (Cons z xs)
  moreover from that have "compare cmp y z = Equiv \<Longrightarrow> compare cmp z x = Equiv"
    by (auto intro: compare.trans_equiv simp add: compare.sym)
  ultimately show ?case
    using that by (auto simp add: compare.greater_iff_sym_less)
qed

lemma stable_insort_not_equiv:
  "stable_segment cmp y (insort cmp x xs) = stable_segment cmp y xs"
    if "compare cmp y x \<noteq> Equiv"
  using that by (induction xs) simp_all

lemma remove1_insort_same_eq [simp]:
  "remove1 x (insort cmp x xs) = xs"
  by (induction xs) simp_all

lemma insort_eq_ConsI:
  "insort cmp x xs = x # xs"
    if "sorted cmp xs" "\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (induction xs) (simp_all add: compare.greater_iff_sym_less)

lemma remove1_insort_not_same_eq [simp]:
  "remove1 y (insort cmp x xs) = insort cmp x (remove1 y xs)"
    if "sorted cmp xs" "x \<noteq> y"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons z zs)
  show ?case
  proof (cases "compare cmp x z = Greater")
    case True
    with Cons show ?thesis
      by simp
  next
    case False
    then have "compare cmp x y \<noteq> Greater" if "y \<in> set zs" for y
      using that Cons.hyps
      by (auto dest: compare.trans_not_greater)
    with Cons show ?thesis
      by (simp add: insort_eq_ConsI)
  qed
qed

lemma insort_remove1_same_eq:
  "insort cmp x (remove1 x xs) = xs"
    if "sorted cmp xs" and "x \<in> set xs" and "hd (stable_segment cmp x xs) = x"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then have "compare cmp x y \<noteq> Less"
    by (auto simp add: compare.greater_iff_sym_less)
  then consider "compare cmp x y = Greater" | "compare cmp x y = Equiv"
    by (cases "compare cmp x y") auto
  then show ?case proof cases
    case 1
    with Cons.prems Cons.IH show ?thesis
      by auto
  next
    case 2
    with Cons.prems have "x = y"
      by simp
    with Cons.hyps show ?thesis
      by (simp add: insort_eq_ConsI)
  qed
qed

lemma sorted_append_iff:
  "sorted cmp (xs @ ys) \<longleftrightarrow> sorted cmp xs \<and> sorted cmp ys
     \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. compare cmp x y \<noteq> Greater)" (is "?P \<longleftrightarrow> ?R \<and> ?S \<and> ?Q")
proof
  assume ?P
  have ?R
    using \<open>?P\<close> by (induction xs)
      (auto simp add: sorted_Cons_imp_not_less,
        auto simp add: sorted_Cons_imp_sorted intro: sorted_ConsI)
  moreover have ?S
    using \<open>?P\<close> by (induction xs) (auto dest: sorted_Cons_imp_sorted)
  moreover have ?Q
    using \<open>?P\<close> by (induction xs) (auto simp add: sorted_Cons_imp_not_less,
      simp add: sorted_Cons_imp_sorted)
  ultimately show "?R \<and> ?S \<and> ?Q"
    by simp
next
  assume "?R \<and> ?S \<and> ?Q"
  then have ?R ?S ?Q
    by simp_all
  then show ?P
    by (induction xs)
      (auto simp add: append_eq_Cons_conv intro!: sorted_ConsI)
qed

definition sort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "sort cmp xs = foldr (insort cmp) xs []"

lemma sort_simps [simp]:
  "sort cmp [] = []"
  "sort cmp (x # xs) = insort cmp x (sort cmp xs)"
  by (simp_all add: sort_def)

lemma mset_sort [simp]:
  "mset (sort cmp xs) = mset xs"
  by (induction xs) simp_all

lemma length_sort [simp]:
  "length (sort cmp xs) = length xs"
  by (induction xs) simp_all

lemma sorted_sort [simp]:
  "sorted cmp (sort cmp xs)"
  by (induction xs) (simp_all add: sorted_insort)

lemma stable_sort:
  "stable_segment cmp x (sort cmp xs) = stable_segment cmp x xs"
  by (induction xs) (simp_all add: stable_insort_equiv stable_insort_not_equiv)

lemma sort_remove1_eq [simp]:
  "sort cmp (remove1 x xs) = remove1 x (sort cmp xs)"
  by (induction xs) simp_all

lemma set_insort [simp]:
  "set (insort cmp x xs) = insert x (set xs)"
  by (induction xs) auto

lemma set_sort [simp]:
  "set (sort cmp xs) = set xs"
  by (induction xs) auto

lemma sort_eqI:
  "sort cmp ys = xs"
    if permutation: "mset ys = mset xs"
    and sorted: "sorted cmp xs"
    and stable: "\<And>y. y \<in> set ys \<Longrightarrow>
      stable_segment cmp y ys = stable_segment cmp y xs"
proof -
  have stable': "stable_segment cmp y ys =
    stable_segment cmp y xs" for y
  proof (cases "\<exists>x\<in>set ys. compare cmp y x = Equiv")
    case True
    then obtain z where "z \<in> set ys" and "compare cmp y z = Equiv"
      by auto
    then have "compare cmp y x = Equiv \<longleftrightarrow> compare cmp z x = Equiv" for x
      by (meson compare.sym compare.trans_equiv)
    moreover have "stable_segment cmp z ys =
      stable_segment cmp z xs"
      using \<open>z \<in> set ys\<close> by (rule stable)
    ultimately show ?thesis
      by simp
  next
    case False
    moreover from permutation have "set ys = set xs"
      by (rule mset_eq_setD)
    ultimately show ?thesis
      by simp
  qed
  show ?thesis
  using sorted permutation stable' proof (induction xs arbitrary: ys rule: sorted_induct_remove1)
    case Nil
    then show ?case
      by simp
  next
    case (minimum x xs)
    from \<open>mset ys = mset xs\<close> have ys: "set ys = set xs"
      by (rule mset_eq_setD)
    then have "compare cmp x y \<noteq> Greater" if "y \<in> set ys" for y
      using that minimum.hyps by simp
    from minimum.prems have stable: "stable_segment cmp x ys = stable_segment cmp x xs"
      by simp
    have "sort cmp (remove1 x ys) = remove1 x xs"
      by (rule minimum.IH) (simp_all add: minimum.prems filter_remove1)
    then have "remove1 x (sort cmp ys) = remove1 x xs"
      by simp
    then have "insort cmp x (remove1 x (sort cmp ys)) =
      insort cmp x (remove1 x xs)"
      by simp
    also from minimum.hyps ys stable have "insort cmp x (remove1 x (sort cmp ys)) = sort cmp ys"
      by (simp add: stable_sort insort_remove1_same_eq)
    also from minimum.hyps have "insort cmp x (remove1 x xs) = xs"
      by (simp add: insort_remove1_same_eq)
    finally show ?case .
  qed
qed

lemma filter_insort:
  "filter P (insort cmp x xs) = insort cmp x (filter P xs)"
    if "sorted cmp xs" and "P x"
  using that by (induction xs)
    (auto simp add: compare.trans_not_greater insort_eq_ConsI)

lemma filter_insort_triv:
  "filter P (insort cmp x xs) = filter P xs"
    if "\<not> P x"
  using that by (induction xs) simp_all

lemma filter_sort:
  "filter P (sort cmp xs) = sort cmp (filter P xs)"
  by (induction xs) (auto simp add: filter_insort filter_insort_triv)

section \<open>Alternative sorting algorithms\<close>

subsection \<open>Quicksort\<close>

definition quicksort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where quicksort_is_sort [simp]: "quicksort = sort"

lemma sort_by_quicksort:
  "sort = quicksort"
  by simp

lemma sort_by_quicksort_rec:
  "sort cmp xs = sort cmp [x\<leftarrow>xs. compare cmp x (xs ! (length xs div 2)) = Less]
    @ stable_segment cmp (xs ! (length xs div 2)) xs
    @ sort cmp [x\<leftarrow>xs. compare cmp x (xs ! (length xs div 2)) = Greater]" (is "_ = ?rhs")
proof (rule sort_eqI)
  show "mset xs = mset ?rhs"
    by (rule multiset_eqI) (auto simp add: compare.sym intro: comp.exhaust)
next
  show "sorted cmp ?rhs"
    by (auto simp add: sorted_append_iff sorted_stable_segment compare.equiv_subst_right dest: compare.trans_greater)
next
  let ?pivot = "xs ! (length xs div 2)"
  fix l
  have "compare cmp x ?pivot = comp \<and> compare cmp l x = Equiv
    \<longleftrightarrow> compare cmp l ?pivot = comp \<and> compare cmp l x = Equiv" for x comp
  proof -
    have "compare cmp x ?pivot = comp \<longleftrightarrow> compare cmp l ?pivot = comp"
      if "compare cmp l x = Equiv"
      using that by (simp add: compare.equiv_subst_left compare.sym)
    then show ?thesis by blast
  qed
  then show "stable_segment cmp l xs = stable_segment cmp l ?rhs"
    by (simp add: stable_sort compare.sym [of _ ?pivot])
      (cases "compare cmp l ?pivot", simp_all)
qed

context
begin

qualified definition partition :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list \<times> 'a list"
  where "partition cmp pivot xs =
    ([x \<leftarrow> xs. compare cmp x pivot = Less], stable_segment cmp pivot xs, [x \<leftarrow> xs. compare cmp x pivot = Greater])"

qualified lemma partition_code [code]:
  "partition cmp pivot [] = ([], [], [])"
  "partition cmp pivot (x # xs) =
    (let (lts, eqs, gts) = partition cmp pivot xs
     in case compare cmp x pivot of
       Less \<Rightarrow> (x # lts, eqs, gts)
     | Equiv \<Rightarrow> (lts, x # eqs, gts)
     | Greater \<Rightarrow> (lts, eqs, x # gts))"
  using comp.exhaust by (auto simp add: partition_def Let_def compare.sym [of _ pivot])

lemma quicksort_code [code]:
  "quicksort cmp xs =
    (case xs of
      [] \<Rightarrow> []
    | [x] \<Rightarrow> xs
    | [x, y] \<Rightarrow> (if compare cmp x y \<noteq> Greater then xs else [y, x])
    | _ \<Rightarrow>
        let (lts, eqs, gts) = partition cmp (xs ! (length xs div 2)) xs
        in quicksort cmp lts @ eqs @ quicksort cmp gts)"
proof (cases "length xs \<ge> 3")
  case False
  then have "length xs \<in> {0, 1, 2}"
    by (auto simp add: not_le le_less less_antisym)
  then consider "xs = []" | x where "xs = [x]" | x y where "xs = [x, y]"
    by (auto simp add: length_Suc_conv numeral_2_eq_2)
  then show ?thesis
    by cases simp_all
next
  case True
  then obtain x y z zs where "xs = x # y # z # zs"
    by (metis le_0_eq length_0_conv length_Cons list.exhaust not_less_eq_eq numeral_3_eq_3)
  moreover have "quicksort cmp xs =
    (let (lts, eqs, gts) = partition cmp (xs ! (length xs div 2)) xs
    in quicksort cmp lts @ eqs @ quicksort cmp gts)"
    using sort_by_quicksort_rec [of cmp xs] by (simp add: partition_def)
  ultimately show ?thesis
    by simp
qed

end

subsection \<open>Mergesort\<close>

definition mergesort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where mergesort_is_sort [simp]: "mergesort = sort"

lemma sort_by_mergesort:
  "sort = mergesort"
  by simp

context
  fixes cmp :: "'a comparator"
begin

qualified function merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "merge [] ys = ys"
  | "merge xs [] = xs"
  | "merge (x # xs) (y # ys) = (if compare cmp x y = Greater
      then y # merge (x # xs) ys else x # merge xs (y # ys))"
  by pat_completeness auto

qualified termination by lexicographic_order

lemma mset_merge:
  "mset (merge xs ys) = mset xs + mset ys"
  by (induction xs ys rule: merge.induct) simp_all

lemma merge_eq_Cons_imp:
  "xs \<noteq> [] \<and> z = hd xs \<or> ys \<noteq> [] \<and> z = hd ys"
    if "merge xs ys = z # zs"
  using that by (induction xs ys rule: merge.induct) (auto split: if_splits)

lemma filter_merge:
  "filter P (merge xs ys) = merge (filter P xs) (filter P ys)"
    if "sorted cmp xs" and "sorted cmp ys"
using that proof (induction xs ys rule: merge.induct)
  case (1 ys)
  then show ?case
    by simp
next
  case (2 xs)
  then show ?case
    by simp
next
  case (3 x xs y ys)
  show ?case
  proof (cases "compare cmp x y = Greater")
    case True
    with 3 have hyp: "filter P (merge (x # xs) ys) =
      merge (filter P (x # xs)) (filter P ys)"
      by (simp add: sorted_Cons_imp_sorted)
    show ?thesis
    proof (cases "\<not> P x \<and> P y")
      case False
      with \<open>compare cmp x y = Greater\<close> show ?thesis
        by (auto simp add: hyp)
    next
      case True
      from \<open>compare cmp x y = Greater\<close> "3.prems"
      have *: "compare cmp z y = Greater" if "z \<in> set (filter P xs)" for z
        using that by (auto dest: compare.trans_not_greater sorted_Cons_imp_not_less)
      from \<open>compare cmp x y = Greater\<close> show ?thesis
        by (cases "filter P xs") (simp_all add: hyp *)
    qed
  next
    case False
    with 3 have hyp: "filter P (merge xs (y # ys)) =
      merge (filter P xs) (filter P (y # ys))"
      by (simp add: sorted_Cons_imp_sorted)
    show ?thesis
    proof (cases "P x \<and> \<not> P y")
      case False
      with \<open>compare cmp x y \<noteq> Greater\<close> show ?thesis
        by (auto simp add: hyp)
    next
      case True
      from \<open>compare cmp x y \<noteq> Greater\<close> "3.prems"
      have *: "compare cmp x z \<noteq> Greater" if "z \<in> set (filter P ys)" for z
        using that by (auto dest: compare.trans_not_greater sorted_Cons_imp_not_less)
      from \<open>compare cmp x y \<noteq> Greater\<close> show ?thesis
        by (cases "filter P ys") (simp_all add: hyp *)
    qed
  qed
qed

lemma sorted_merge:
  "sorted cmp (merge xs ys)" if "sorted cmp xs" and "sorted cmp ys"
using that proof (induction xs ys rule: merge.induct)
  case (1 ys)
  then show ?case
    by simp
next
  case (2 xs)
  then show ?case
    by simp
next
  case (3 x xs y ys)
  show ?case
  proof (cases "compare cmp x y = Greater")
    case True
    with 3 have "sorted cmp (merge (x # xs) ys)"
      by (simp add: sorted_Cons_imp_sorted)
    then have "sorted cmp (y # merge (x # xs) ys)"
    proof (rule sorted_ConsI)
      fix z zs
      assume "merge (x # xs) ys = z # zs"
      with 3(4) True show "compare cmp y z \<noteq> Greater"
        by (clarsimp simp add: sorted_Cons_imp_sorted dest!: merge_eq_Cons_imp)
          (auto simp add: compare.asym_greater sorted_Cons_imp_not_less)
    qed
    with True show ?thesis
      by simp
  next
    case False
    with 3 have "sorted cmp (merge xs (y # ys))"
      by (simp add: sorted_Cons_imp_sorted)
    then have "sorted cmp (x # merge xs (y # ys))"
    proof (rule sorted_ConsI)
      fix z zs
      assume "merge xs (y # ys) = z # zs"
      with 3(3) False show "compare cmp x z \<noteq> Greater"
        by (clarsimp simp add: sorted_Cons_imp_sorted dest!: merge_eq_Cons_imp)
          (auto simp add: compare.asym_greater sorted_Cons_imp_not_less)
    qed
    with False show ?thesis
      by simp
  qed
qed

lemma merge_eq_appendI:
  "merge xs ys = xs @ ys"
    if "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (induction xs ys rule: merge.induct) simp_all

lemma merge_stable_segments:
  "merge (stable_segment cmp l xs) (stable_segment cmp l ys) =
     stable_segment cmp l xs @ stable_segment cmp l ys"
  by (rule merge_eq_appendI) (auto dest: compare.trans_equiv_greater)

lemma sort_by_mergesort_rec:
  "sort cmp xs =
    merge (sort cmp (take (length xs div 2) xs))
      (sort cmp (drop (length xs div 2) xs))" (is "_ = ?rhs")
proof (rule sort_eqI)
  have "mset (take (length xs div 2) xs) + mset (drop (length xs div 2) xs) =
    mset (take (length xs div 2) xs @ drop (length xs div 2) xs)"
    by (simp only: mset_append)
  then show "mset xs = mset ?rhs"
    by (simp add: mset_merge)
next
  show "sorted cmp ?rhs"
    by (simp add: sorted_merge)
next
  fix l
  have "stable_segment cmp l (take (length xs div 2) xs) @ stable_segment cmp l (drop (length xs div 2) xs)
    = stable_segment cmp l xs"
    by (simp only: filter_append [symmetric] append_take_drop_id)
  have "merge (stable_segment cmp l (take (length xs div 2) xs))
    (stable_segment cmp l (drop (length xs div 2) xs)) =
    stable_segment cmp l (take (length xs div 2) xs) @ stable_segment cmp l (drop (length xs div 2) xs)"
    by (rule merge_eq_appendI) (auto simp add: compare.trans_equiv_greater)
  also have "\<dots> = stable_segment cmp l xs"
    by (simp only: filter_append [symmetric] append_take_drop_id)
  finally show "stable_segment cmp l xs = stable_segment cmp l ?rhs"
    by (simp add: stable_sort filter_merge)
qed

lemma mergesort_code [code]:
  "mergesort cmp xs =
    (case xs of
      [] \<Rightarrow> []
    | [x] \<Rightarrow> xs
    | [x, y] \<Rightarrow> (if compare cmp x y \<noteq> Greater then xs else [y, x])
    | _ \<Rightarrow>
        let
          half = length xs div 2;
          ys = take half xs;
          zs = drop half xs
        in merge (mergesort cmp ys) (mergesort cmp zs))"
proof (cases "length xs \<ge> 3")
  case False
  then have "length xs \<in> {0, 1, 2}"
    by (auto simp add: not_le le_less less_antisym)
  then consider "xs = []" | x where "xs = [x]" | x y where "xs = [x, y]"
    by (auto simp add: length_Suc_conv numeral_2_eq_2)
  then show ?thesis
    by cases simp_all
next
  case True
  then obtain x y z zs where "xs = x # y # z # zs"
    by (metis le_0_eq length_0_conv length_Cons list.exhaust not_less_eq_eq numeral_3_eq_3)
  moreover have "mergesort cmp xs =
    (let
       half = length xs div 2;
       ys = take half xs;
       zs = drop half xs
     in merge (mergesort cmp ys) (mergesort cmp zs))"
    using sort_by_mergesort_rec [of xs] by (simp add: Let_def)
  ultimately show ?thesis
    by simp
qed

end

end


theory sledgeCategoryProofs imports sledgeCategoryV3

begin

(*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 300]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 e vampire remote_leo3, timeout = 120, isar_proofs = false]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section\<open>Proofs in Categories\<close>

context category begin
(*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)

  subsection\<open>About initial and final\<close>

\<comment>\<open>Checking equivalences of initial - the same would do for final\<close>
lemma StrongerInitial1: "(initial z) \<longrightarrow>  (\<^bold>\<forall>t.(type t)\<longrightarrow> (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t))" (*  sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)]*)
  by (metis S2 S3 S5)

lemma StrongerInitial2: "(\<^bold>\<forall>t. (type t)\<longrightarrow>(\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)) \<longrightarrow> initial z"  (*sledgehammer sledgehammer [remote_leo3]*)
  by (metis local.S1)

lemma WeakerInitial1: "(\<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t)) \<longrightarrow> initial z" (* sledgehammer sledgehammer [remote_leo3] *)
  by (smt S5 S2 S3 category_axioms)

lemma WeakerInitial2: "(initial z) \<longrightarrow> (\<^bold>\<forall>t. (type t) \<longrightarrow> (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t))"
  by (metis S1)

lemma InitialsAreIsomorphic: "initial z \<and> initial y \<longrightarrow> z \<^bold>\<cong> y"
  by (smt catAx(1) catAx(2) catAx(3) catAx(4) catAx(5) catAx(6))

lemma InitialIsUnique: "\<forall>z. \<forall>f. initial z \<and> (dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S3 S5 S6)

lemma FinalsAreIsomorphic: "final z \<and> final y \<longrightarrow> z \<^bold>\<cong> y" (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S3 S4 S5 S6)

lemma FinalIsUnique: "\<forall>z. \<forall>f. final z \<and> ( dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" (* sledgehammer sledgehammer [remote_leo3] *)
  by (metis S2 S3 S5 S6)

lemma TwoMonicsBetweenTypes: "(\<^bold>\<forall>(m::'a) (n::'a). monic m \<and> monic n \<and> dom m \<simeq> dom n \<and> cod m \<simeq> cod n \<longrightarrow> (m\<simeq>n))" nitpick oops

  subsection\<open>About epi and mono\<close>

proposition "isomorphism m \<longrightarrow> monic m \<and> epi m"  \<comment>\<open>cvc4 and Leo-III find proof\<close>
  (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer [remote_leo3](S1 S2 S3 S4 S5 S6)*)
  by (smt S1 S3 S4 S5 S6)

lemma "monic m \<and> epi m \<longrightarrow> isomorphism m" nitpick oops

  subsection\<open>About products\<close>

lemma productIso: "product a b c t1 t2 \<and> product a b d q1 q2 \<longrightarrow> c \<^bold>\<cong> d"
   by (smt S1 S2 S4 S3 S5 S6)

lemma productSym: "((product b a c q1 q2) \<longrightarrow>  (product a b c q2 q1))"
  by smt

lemma productUnit: "final (u) \<and> typeE a \<longrightarrow> (\<^bold>\<exists>p1 p2. product u a a p1 p2)"
  by (smt S3 S4 S5 S6)

\<comment> \<open>This enables us to generally define the product for all morphisms\<close>
lemma "\<^bold>\<forall>a b c p1 p2 q1 q2. (product  (dom a) (dom b) c p1 p2) \<and> (product (cod a) (cod b) c q1 q2) \<longrightarrow>
                      (\<^bold>\<exists>!f. (commSquareE a p1 f q1 \<and> commSquareE b p2 f q2))"
  by (smt S3 S4 S5 S6)

(*nitpick finds counterexample*)
lemma mapToInitial: "(initial z \<and> (\<^bold>\<exists>f. f:A\<rightarrow>z)) \<longrightarrow> initial A" nitpick oops

end

section\<open>Category with binary products\<close>
context productCategory begin

proposition prodWithFinal: "final (u) \<and> typeE A \<longrightarrow> (u \<^bold>\<times> A) \<^bold>\<cong> A"
proof
  assume assm: "final (u) \<and> typeE A"
  then have "\<^bold>\<exists>p1 p2. product u A A p1 p2" using productUnit by auto
  then obtain q1::'a and q2::'a  where prodAssm: "product u A A q1 q2" using assm by smt

  have "typeE u \<and> typeE A" using assm
    by (metis catAx(3) catAx(6))
  then have "product u A (u \<^bold>\<times> A) (p1 (u \<^bold>\<times> A)) (p2 (u \<^bold>\<times> A)) \<and> product u A A q1 q2" using prodCat4 prodAssm by auto
  thus "(u \<^bold>\<times> A) \<^bold>\<cong> A" using productIso[of "(p1 (u \<^bold>\<times> A))" "(u \<^bold>\<times> A)" u "(p2 (u \<^bold>\<times> A))" A q1 A q2 ] by (rule rev_mp)
qed

(* z3 finds proof but timeout*)
proposition SymOfProduct: "typeE A \<and> typeE B \<longrightarrow> (A \<^bold>\<times> B) \<^bold>\<cong> (B \<^bold>\<times> A)"
proof (rule impI)
  assume assm: "typeE A \<and> typeE B"
  have "product A B (A \<^bold>\<times> B) (p1 (A \<^bold>\<times> B)) (p2 (A \<^bold>\<times> B))" using prodCat4 assm by auto
  then have 1:"product B A (A \<^bold>\<times> B) (p2 (A \<^bold>\<times> B)) (p1 (A \<^bold>\<times> B))" by (rule productSym[THEN impE])
  have "product B A (B \<^bold>\<times> A) (p1 (B \<^bold>\<times> A)) (p2 (B \<^bold>\<times> A))" using prodCat4 assm by auto
  thus "(A \<^bold>\<times> B) \<^bold>\<cong> (B \<^bold>\<times> A)"
    using 1 productIso[where ?a = B and ?b = A and ?c = "(A \<^bold>\<times> B)" and ?d = "(B \<^bold>\<times> A)" and
                            ?t1.0 = "(p2 (A \<^bold>\<times> B))" and ?t2.0 = "(p1 (A \<^bold>\<times> B))" and ?q1.0 = "(p1 (B \<^bold>\<times> A))"
                            and ?q2.0 = "(p2 (B \<^bold>\<times> A))"] by auto
qed

proposition AssocOfProduct: "typeE A \<and> typeE B \<and> typeE C \<longrightarrow> ((A \<^bold>\<times> B) \<^bold>\<times> C) \<^bold>\<cong> (A \<^bold>\<times> (B \<^bold>\<times> C))" oops

(*Rule which is used in prodWithInitial*)
lemma domP1: "E (f \<cdot> (p1 (a \<^bold>\<times> b))) \<and> type a \<and> type b \<Longrightarrow> dom (f\<cdot>(p1 (a \<^bold>\<times> b))) \<simeq> (a \<^bold>\<times> b)"
  by (smt prodCatAx(10) prodCatAx(2) prodCatAx(3) prodCatAx(4) prodCatAx(5) prodCatAx(7) prodCatAx(8))
end

section\<open>Proofs in Cartesian Categories\<close>

context cartesianCategory begin

subsection\<open>Pullbacks\<close>

\<comment> \<open>z3 finds proof\<close>
proposition pastingLemma: "pullback g p t f \<and> pullback t q s h \<and> commSquare g (p\<cdot>q) s (f\<cdot>h) \<longrightarrow> pullback g (p\<cdot>q) s (f\<cdot>h)"  (*sledgehammer(S1 S2 S3 S4 S5 S6) sledgehammer[remote_leo3] (S1 S2 S3 S4 S5 S6)*)
  by (smt cartesianAx(1) cartesianAx(2) cartesianAx(3) cartesianAx(4) cartesianAx(5) cartesianAx(6))

lemma "typeE A \<and> initial z \<longrightarrow> ((z \<^bold>\<times> A) \<^bold>\<cong> A)"
proof
  assume assm: "typeE A \<and> initial z"
  then obtain f::'a where 1:"f:z\<rightarrow>A \<and> (\<^bold>\<forall>g. g:z\<rightarrow>A \<longrightarrow> g \<simeq> f)" by force
  have "product z A z z f"
    apply(rule conjI)
     apply (metis 1 local.S2 local.S3 local.S5 local.S6)
    apply(rule conjI)
     apply (metis 1)
  proof (rule fall3I, rule impI)
    fix x::'a and v::'a and w::'a
    assume "E x \<and> E v \<and> E w" and "z\<leftarrow>v- x -w\<rightarrow>A"
    show "\<^bold>\<exists>!h. h:x\<rightarrow>z \<and> v \<simeq> z\<cdot>h \<and> w \<simeq> f\<cdot>h" oops

end

section\<open>Proofs in Cartesian Closed Categories\<close>

context exponentialCategory begin

lemma prodWithInitial: "initial z \<and> typeE A \<longrightarrow> initial (z \<^bold>\<times> A)"
proof
  assume assm: "initial z \<and> typeE A"
  show "initial (z \<^bold>\<times> A)"
    apply(rule fallI, intro impI)
  proof -
    fix x assume 1: "E x" and 2: "type x"
    then have "\<exists>!f. E f \<and> f:z\<rightarrow>x" using assm by blast
    then obtain f where 3: "E f \<and> f:z\<rightarrow>x \<and> (\<forall>g. E g \<and> g:z\<rightarrow>x \<longrightarrow> g = f)" by auto
    show "(\<^bold>\<exists>!f. f:(z \<^bold>\<times> A)\<rightarrow>x)"
      apply(rule fexI[of "f\<cdot>(p1(z \<^bold>\<times> A))"], rule conjI)
      apply (metis "3" assm prodCatAx(10) prodCatAx(3) prodCatAx(5) prodCatAx(6), rule conjI, rule conjI, rule domP1)
        apply (metis "3" assm prodCatAx(10) prodCatAx(3) prodCatAx(5) prodCatAx(6))
       apply (metis "3" assm prodCatAx(10) prodCatAx(3) prodCatAx(4) prodCatAx(5) prodCatAx(6))
    proof (rule fallI, rule impI, rule impI)
      fix g assume 6:"E g" and 7:"g:(z \<^bold>\<times> A)\<rightarrow>x"
      then have 4:"(tp g):z\<rightarrow>(exp x A)"
        by (metis "2" assm expCatAx(18))
      have 5: "(f \<cdot> p1 (z \<^bold>\<times> A)):(z \<^bold>\<times> A)\<rightarrow>x"
        apply(rule conjI, rule domP1)
        apply (metis "3" assm prodCatAx(10) prodCatAx(3) prodCatAx(5) prodCatAx(6))
        by (metis "3" assm prodCatAx(10) prodCatAx(3) prodCatAx(4) prodCatAx(5) prodCatAx(6))
      moreover have "(tp (f\<cdot>(p1 (z \<^bold>\<times> A)))):z\<rightarrow>(exp x A)"
        by (metis "5" assm expCatAx(18) expCatAx(2) expCatAx(3) expCatAx(6))
      then have 8:"(tp (f\<cdot>(p1 (z \<^bold>\<times> A)))) = (tp g)" using 4
        by (metis assm catAx(1) catAx(3) catAx(6))
      have 9:"(\<epsilon> A x) \<cdot> ((tp g) \<^bold>\<times> A) \<simeq> g"
        by (metis "2" "6" "7" assm expCatAxPure(1))
      have 10:"(\<epsilon> A x) \<cdot> ((tp (f\<cdot>(p1 (z \<^bold>\<times> A)))) \<^bold>\<times> A) \<simeq> f\<cdot>(p1 (z \<^bold>\<times> A))"
        by (metis "2" "5" assm catAx(1) expCatAxPure(1))
      have "(\<epsilon> A x) \<cdot> ((tp (f\<cdot>(p1 (z \<^bold>\<times> A)))) \<^bold>\<times> A) \<simeq> g" using 8 9 by auto
      thus "g = f\<cdot>(p1 (z \<^bold>\<times> A))" using 10
        by blast
    qed
  qed
qed

lemma "initial z \<and> typeE A \<longrightarrow> ((z \<^bold>\<times> A) \<^bold>\<cong> z)"
proof (rule impI)
  assume assm: "initial z \<and> typeE A"
  then have 1: "initial (z \<^bold>\<times> A)" using prodWithInitial by auto
  from assm have "initial z" by simp
  thus "(z \<^bold>\<times> A) \<^bold>\<cong> z" using InitialsAreIsomorphic 1 by auto
qed

(*lemma "(type A \<and> type B \<and> type C) \<longrightarrow> ((A \<^bold>\<times> B)\<^sup>C) \<cong> ((A\<^sup>C) \<^bold>\<times> (B\<^sup>C))" sledgehammer(axiomSet)

lemma "\<^bold>\<forall>A. type A \<longrightarrow> (\<^bold>1\<^sub>c\<^sup>A) \<simeq> \<^bold>1\<^sub>c"  (*sledgehammer(axiomSet) sledgehammer [remote_leo3](axiomSet)*)
  by (smt axiomSet(12) axiomSet(13) axiomSet(15))

lemma "(type A \<and> type B \<and> type C) \<longrightarrow> ((B\<^sup>A)\<^sup>C) \<cong> exp B (A \<^bold>\<times> C)"  (*sledgehammer(axiomSet) sledgehammer [remote_leo3](axiomSet)*)
  by (smt axiomSet(11) axiomSet(13) axiomSet(14) axiomSet(15) axiomSet(2) axiomSet(7) axiomSet(8))

lemma "\<^bold>\<forall>A. type A \<longrightarrow> (exp A \<^bold>1\<^sub>c) \<simeq> \<^bold>1\<^sub>c"  (*sledgehammer(axiomSet) sledgehammer [remote_leo3](axiomSet)*)
  by (smt axiomSet(12) axiomSet(13) axiomSet(15)) *)

end

section\<open>Proofs about Functors\<close>
(*
\<comment> \<open>None of the proofs work with metis here even though they do in Category_Abbrevs.thy\<close>
lemma ExpIsFunc: "typeE A \<longrightarrow> isFunctor (\<lambda>(x). (x\<^sup>A))"
apply(simp add: imp_conjR)
  apply(rule conjI)
   apply (smt axiomSet(10) axiomSet(7) axiomSet(9))
  apply(rule conjI)
  apply (smt axiomSet(1) axiomSet(10) axiomSet(3) axiomSet(6) axiomSet(9))
  apply(rule conjI) sledgehammer(axiomSet) sledgehammer [remote_leo3](axiomSet)
  apply (smt axiomSet(1) axiomSet(10) axiomSet(10) axiomSet(3) axiomSet(6) axiomSet(9))
  by (smt axiomSet(9))

proposition "\<^bold>\<forall>A. isFunctor (\<lambda>x. (x\<^sup>A))"
  using ExpIsFunc by blast*)

section\<open>Topos\<close>

context topos begin

proposition DiagonalMapIsMonic: "monic (\<Delta> B)" (*sledgehammer(axiomSetTopos)*)
  by (smt axiomSetTopos(1) axiomSetTopos(19) axiomSetTopos(22) axiomSetTopos(3) axiomSetTopos(4) axiomSetTopos(5) axiomSetTopos(6))

abbreviation PredicateOfEquality::"'a \<Rightarrow> 'a" ("\<delta>") where
  "\<delta> \<equiv> \<lambda>B. char (\<Delta> B)"

proposition MonoIsEqualizer: "(E m \<and> monic m) \<longrightarrow> (\<exists>s. (isEqualizer (char m) (true\<cdot>s) m))"
  apply(rule impI)
proof -
  assume 1: "E m \<and> monic m"
  have "isEqualizer (char m) (true\<cdot>(\<^bold>! (dom m))) m"
  proof -
    have 4:"monic (cod m)"
      by (metis S1 S2 S3 S6)
    then have "pullback true (\<^bold>! (dom(cod m))) (cod m) (char (cod m))" using 1 T1
      by (smt S2) \<comment> \<open>Takes some time\<close>
    hence "(char (cod m))\<cdot>m \<cong> (true\<cdot>(\<^bold>! (dom m)))\<cdot>m" sledgehammer(axiomSetTopos 1)
      by (smt "1" axiomSetTopos(16) axiomSetTopos(3) axiomSetTopos(5) axiomSetTopos(6))
    thus ?thesis  sledgehammer(axiomSetTopos 1)
      by (smt "1" axiomSetTopos(1) axiomSetTopos(12) axiomSetTopos(14) axiomSetTopos(15) axiomSetTopos(16) axiomSetTopos(2) axiomSetTopos(20) axiomSetTopos(3) axiomSetTopos(4) axiomSetTopos(5) axiomSetTopos(6))
      by (smt "1" axiomSetTopos(15) axiomSetTopos(3) axiomSetTopos(5) axiomSetTopos(6))
  qed
  then show "\<exists>s. isEqualizer (char m) (true\<cdot>s) m" by (intro exI)
qed

lemma "type A" sledgehammer(axiomSetTopos)

proposition MonoEpiIso: "\<^bold>\<forall>m. monic m \<and> epi m \<longrightarrow> isomorphism m" sledgehammer(axiomSetTopos MonoIsEqualizer) sledgehammer[remote_leo3](axiomSetTopos)*)
  by (metis axiomSetTopos(1) axiomSetTopos(15) axiomSetTopos(3) axiomSetTopos(5))
  apply(rule fallI, rule impI, rule impI)
proof -
  fix m
  assume 1: "E m" and 2: "monic m \<and> epi m"

  from 2 have "\<exists>f g. isEqualizer f g m" using MonoIsEqualizer by blast
  then obtain f g where 3: "isEqualizer f g m" by auto
  hence 4:"f\<cdot>m \<cong> g\<cdot>m" by blast
  then have "f\<cdot>m \<simeq> g\<cdot>m" using 1 S1 S2 S3 S4 S5 S6 by blast
  show "isomorphism m"
qed

end

end


subsection \<open> Alphabetised Relations \<close>

theory utp_rel
  imports utp_pred utp_pred_laws utp_rel_syntax utp_recursion
begin

subsection \<open> Relational Types \<close>

unbundle UTP_Logic_Syntax

text \<open> An alphabetised relation is simply a predicate whose state-space is a product type. In this
  theory we construct the core operators of the relational calculus, and prove a libary of
  associated theorems, based on Chapters 2 and 5 of the UTP book~\cite{Hoare&98}.

  We create type synonyms for alphabetised relations where the input and output alphabet can
  be different, and also homogeneous relations. \<close>

type_synonym ('a, 'b) urel = "('a \<times> 'b) \<Rightarrow> bool"

translations
  (type) "('a, 'b) urel" <= (type) "('a \<times> 'b) \<Rightarrow> bool"

type_synonym 'a hrel = "('a, 'a) urel"

text \<open> The following code sets up pretty-printing for homogeneous relational expressions. We cannot
  do this via the ``translations'' command as we only want the rule to apply when the input and output
  alphabet types are the same. The code has to deconstruct an expression (function) type, determine
  that it is relational (product alphabet), and then checks if the types \emph{alpha} and \emph{beta}
  are the same. If they are, the type is printed as a @{type hrel}. Otherwise, we have no match.
  We then set up a regular translation for the @{type hrel} type that uses this. \<close>

print_translation \<open>
let
fun tr' ctx [ Const (@{type_syntax "prod"},_) $ alpha $ beta
            , Const (@{type_syntax "bool"},t) ] =
  if (alpha = beta)
    then Syntax.const @{type_syntax "hrel"} $ alpha
    else raise Match;
in [(@{type_syntax "fun"},tr')]
end
\<close>

subsection \<open> Relational Alphabets \<close>

text \<open> We set up convenient syntax to refer to the input and output parts of the alphabet, as is
  common in UTP. Since we are in a product space, these are simply the lenses @{term "fst\<^sub>L"} and
  @{term "snd\<^sub>L"} lifted into alphabets. \<close>

definition in\<alpha> :: "('\<alpha> \<times> '\<beta>) scene" where
[lens_defs, expr_simps]: "in\<alpha> = var_alpha fst\<^sub>L"

definition out\<alpha> :: "('\<alpha> \<times> '\<beta>) scene" where
[lens_defs, expr_simps]: "out\<alpha> \<equiv> var_alpha snd\<^sub>L"

lemma in\<alpha>_idem_scene [simp]: "idem_scene in\<alpha>"
  by (simp add: in\<alpha>_def)

lemma out\<alpha>_idem_scene [simp]: "idem_scene out\<alpha>"
  by (simp add: out\<alpha>_def)

lemma in\<alpha>_out\<alpha>_indeps [simp]: "in\<alpha> \<bowtie>\<^sub>S out\<alpha>" "out\<alpha> \<bowtie>\<^sub>S in\<alpha>"
  by (simp_all add: in\<alpha>_def out\<alpha>_def)

lemma alpha_in_out: "in\<alpha> \<squnion>\<^sub>S out\<alpha> = \<top>\<^sub>S"
proof -
  have "fst\<^sub>L +\<^sub>L snd\<^sub>L \<approx>\<^sub>L 1\<^sub>L"
    by (simp add: fst_snd_id_lens)
  hence "\<lbrakk>fst\<^sub>L\<rbrakk>\<^sub>\<sim> \<squnion>\<^sub>S \<lbrakk>snd\<^sub>L\<rbrakk>\<^sub>\<sim> = \<top>\<^sub>S"
    by (simp add: fst_snd_id_lens one_lens_scene scene_space_lemmas(1))
  thus ?thesis
    by (simp add: in\<alpha>_def out\<alpha>_def var_alpha_def)
qed

subsection \<open> Relational Operators \<close>

text \<open> We define a specialised version of the conditional where the condition can refer only to
  undashed variables, as is usually the case in programs, but not universally in UTP models. \<close>

definition rcond :: "('a, 'b) urel \<Rightarrow> 'a pred \<Rightarrow> ('a, 'b) urel \<Rightarrow> ('a, 'b) urel" where
[pred]: "rcond P b Q = expr_if P (b\<^sup><) Q"

adhoc_overloading ucond rcond

lemma rcond_alt_def: "P \<lhd> b \<rhd> Q = P \<triangleleft> b\<^sup>< \<triangleright> Q"
  by pred_simp

text \<open> Sequential composition is heterogeneous, and simply requires that the output alphabet
  of the first matches then input alphabet of the second. \<close>

definition seq :: "('a, 'b) urel \<Rightarrow> ('b, 'c) urel \<Rightarrow> ('a, 'c) urel" where
[pred]: "seq P Q = (\<lambda> (s, s'). \<exists> s\<^sub>0. P (s, s\<^sub>0) \<and> Q (s\<^sub>0, s'))"

adhoc_overloading useq seq

text \<open> We also set up a homogeneous sequential composition operator, and versions of @{term true}
  and @{term false} that are explicitly typed by a homogeneous alphabet. \<close>

abbreviation truer :: "'s hrel" ("true\<^sub>h") where
"truer \<equiv> true"

abbreviation falser :: "'s hrel" ("false\<^sub>h") where
"falser \<equiv> false"

text \<open> We define the relational converse operator as an alphabet extrusion on the bijective
  lens @{term swap\<^sub>L} that swaps the elements of the product state-space. \<close>

abbreviation conv_r :: "('a, 'b) urel \<Rightarrow> ('b, 'a) urel" ("_\<^sup>-" [999] 999) where
"conv_r P \<equiv> aext P swap\<^sub>L"

text \<open> Assignment is defined using substitutions, where latter defines what each variable should
  map to. This approach, which is originally due to Back~\cite{Back1998}, permits more general
  assignment expressions. The definition of the operator identifies the after state binding, $b'$,
  with the substitution function applied to the before state binding $b$. \<close>

definition assigns_r :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('s\<^sub>1, 's\<^sub>2) urel" where
[pred]: "assigns_r \<sigma> = (\<lambda> (s, s'). s' = \<sigma> s)"

adhoc_overloading uassigns assigns_r

text \<open> Relational identity, or skip, leaves all variables unchanged. \<close>

definition skip :: "'a hrel" where
[pred]: "skip = (\<lambda> (s, s'). s' = s)"

adhoc_overloading uskip skip

text \<open> Non-deterministic assignment, also known as ``choose'', assigns an arbitrarily chosen value
  to the given variable \<close>

definition ndet_assign :: "('a \<Longrightarrow> 's) \<Rightarrow> 's hrel" where
[pred]: "ndet_assign x = (\<Sqinter> v. x := \<guillemotleft>v\<guillemotright>)"

syntax "_ndet_assign" :: "svid \<Rightarrow> logic" ("_ := *" [75] 76)
translations "_ndet_assign x" == "CONST ndet_assign x"

text \<open> We set up iterated sequential composition which iterates an indexed predicate over the
  elements of a list. \<close>

definition seqr_iter :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b hrel) \<Rightarrow> 'b hrel" where
[pred]: "seqr_iter xs P = foldr (\<lambda> i Q. P(i) ;; Q) xs II"

syntax "_seqr_iter" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3;; _ : _ \<bullet>/ _)" [0, 0, 10] 10)
translations ";; x : l \<bullet> P" \<rightleftharpoons> "(CONST seqr_iter) l (\<lambda>x. P)"

text \<open> We also define the alphabetised skip operator that identifies all input and output variables
  in the given alphabet scene. All other variables are unrestricted. We also set up syntax for it. \<close>

definition skip_ra :: "'s scene \<Rightarrow> 's hrel" where
[pred]: "skip_ra a = (\<lambda> (s, s'). s' \<approx>\<^sub>S s on a)"

definition test :: "('s \<Rightarrow> bool) \<Rightarrow> 's hrel" where
[pred]: "test b = (\<lambda> (s, s'). b s \<and> s' = s)"

adhoc_overloading utest test

definition while_top :: "(bool, 's) expr \<Rightarrow> 's hrel \<Rightarrow> 's hrel" ("while\<^sup>\<top> _ do _ od") where
"while_top b P = (\<nu> X \<bullet> ((P ;; X) \<lhd> b \<rhd> II))"

notation while_top ("while _ do _ od")

definition while_bot :: "(bool, 's) expr \<Rightarrow> 's hrel \<Rightarrow> 's hrel" ("while\<^sub>\<bottom> _ do _ od") where
"while_bot b P = (\<mu> X \<bullet> ((P ;; X) \<lhd> b \<rhd> II))"

text \<open> While loops with invariant decoration -- partial correctness\<close>

definition while_inv :: "(bool, 's) expr \<Rightarrow> (bool, 's) expr \<Rightarrow> 's hrel \<Rightarrow> 's hrel" ("while\<^sup>\<top> _ invr _ do _ od") where
"while_inv b p P = while_top b P"

notation while_inv ("while _ invr _ do _ od")

text \<open> While loops with invariant decoration -- total correctness\<close>

definition while_inv_bot :: "(bool, 's) expr \<Rightarrow> (bool, 's) expr \<Rightarrow> 's hrel \<Rightarrow> 's hrel" ("while\<^sub>\<bottom> _ invr _ do _ od") where
"while_inv_bot b p P = while_bot b P"

text \<open> While loops with invariant and variant decoration -- total correctness \<close>

definition while_vrt :: "(bool, 's) expr \<Rightarrow> (bool, 's) expr \<Rightarrow> (nat, 's) expr \<Rightarrow> 's hrel \<Rightarrow> 's hrel"
                        ("while _ invr _ vrt _ do _ od")
where "while_vrt b p v P = while_bot b P"

subsection \<open> Predicate Semantics \<close>

lemma pred_skip: "II = ($\<^bold>v\<^sup>> = $\<^bold>v\<^sup><)\<^sub>e"
  by pred_simp

lemma pred_seq_hom:
  "P ;; Q = (\<exists> v\<^sub>0. [ \<^bold>v\<^sup>> \<leadsto> \<guillemotleft>v\<^sub>0\<guillemotright> ] \<dagger> P \<and> [ \<^bold>v\<^sup>< \<leadsto> \<guillemotleft>v\<^sub>0\<guillemotright> ] \<dagger> Q)\<^sub>e"
  by pred_auto

lemma pred_seq:
  "P ;; Q = (\<exists> v\<^sub>0. \<lparr> \<^bold>v\<^sup>< \<leadsto> $\<^bold>v\<^sup><, \<^bold>v\<^sup>> \<leadsto> \<guillemotleft>v\<^sub>0\<guillemotright> \<rparr> \<dagger> P \<and> \<lparr> \<^bold>v\<^sup>< \<leadsto> \<guillemotleft>v\<^sub>0\<guillemotright>, \<^bold>v\<^sup>> \<leadsto> $\<^bold>v\<^sup>> \<rparr> \<dagger> Q)\<^sub>e"
  by (pred_auto)

subsection \<open> Substitution Laws \<close>

declare seq_def [expr_defs]

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by pred_auto (metis snd_conv)+

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by pred_auto (metis fst_conv)+

subsection \<open> Unrestriction Laws \<close>

lemma unrest_in_var [unrest]: "mwb_lens x \<Longrightarrow> in\<alpha> \<sharp> P \<Longrightarrow> $x\<^sup>< \<sharp> P"
  by expr_auto

lemma unrest_out_var [unrest]: "mwb_lens x \<Longrightarrow> out\<alpha> \<sharp> P \<Longrightarrow> $x\<^sup>> \<sharp> P"
  by expr_auto

lemma unrest_seq_ivar [unrest]: "\<lbrakk> mwb_lens x; $x\<^sup>< \<sharp> P \<rbrakk> \<Longrightarrow> $x\<^sup>< \<sharp> P ;; Q"
  by pred_auto

lemma unrest_seq_ovar [unrest]: "\<lbrakk> mwb_lens x; $x\<^sup>> \<sharp> Q \<rbrakk> \<Longrightarrow> $x\<^sup>> \<sharp> P ;; Q"
  by pred_auto

lemma drop_pre_inv: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> p\<^sub><\<^sup>< = p"
  by pred_simp

subsection \<open> Relational Transfer Method \<close>

definition pred_rel :: "'s pred \<Rightarrow> 's set" ("\<lbrakk>_\<rbrakk>\<^sub>U") where
"pred_rel = Collect"

syntax "_pred_rel" :: "logic \<Rightarrow> logic" ("'(_')\<^sub>U")
translations "(p)\<^sub>U" == "CONST pred_rel (p)\<^sub>e"

named_theorems rel and rel_transfer

lemma rel_pred_interp [rel]:
  "\<lbrakk>true\<rbrakk>\<^sub>U = UNIV" "\<lbrakk>false\<rbrakk>\<^sub>U = {}"
  "\<lbrakk>P \<and> Q\<rbrakk>\<^sub>U = (\<lbrakk>P\<rbrakk>\<^sub>U \<inter> \<lbrakk>Q\<rbrakk>\<^sub>U)" "\<lbrakk>P \<or> Q\<rbrakk>\<^sub>U = (\<lbrakk>P\<rbrakk>\<^sub>U \<union> \<lbrakk>Q\<rbrakk>\<^sub>U)" "\<lbrakk>\<not> P\<rbrakk>\<^sub>U = - \<lbrakk>P\<rbrakk>\<^sub>U"
  by (auto simp add: pred_rel_def pred)

lemma rel_lattice_interp [rel]:
  "\<lbrakk>P \<sqinter> Q\<rbrakk>\<^sub>U = \<lbrakk>P\<rbrakk>\<^sub>U \<union> \<lbrakk>Q\<rbrakk>\<^sub>U" "\<lbrakk>P \<squnion> Q\<rbrakk>\<^sub>U = \<lbrakk>P\<rbrakk>\<^sub>U \<inter> \<lbrakk>Q\<rbrakk>\<^sub>U" "\<lbrakk>\<top>\<rbrakk>\<^sub>U = {}" "\<lbrakk>\<bottom>\<rbrakk>\<^sub>U = UNIV"
  by (auto simp add: pred_rel_def)

lemma rel_complete_lattice_interp [rel]:
  "\<lbrakk>\<Sqinter> i\<in>I. P(i)\<rbrakk>\<^sub>U = (\<Union> i\<in>I. \<lbrakk>P(i)\<rbrakk>\<^sub>U)" "\<lbrakk>\<Squnion> i\<in>I. P(i)\<rbrakk>\<^sub>U = (\<Inter> i\<in>I. \<lbrakk>P(i)\<rbrakk>\<^sub>U)"
  by (auto simp add: pred_rel_def)

lemma rel_interp [rel]:
  "\<lbrakk>P ;; Q\<rbrakk>\<^sub>U = \<lbrakk>P\<rbrakk>\<^sub>U \<Zcomp> \<lbrakk>Q\<rbrakk>\<^sub>U" "\<lbrakk>II\<rbrakk>\<^sub>U = Id"
  by (auto simp add: pred_rel_def pred)

lemma rel_eq_transfer [rel_transfer]: "P = Q \<longleftrightarrow> \<lbrakk>P\<rbrakk>\<^sub>U = \<lbrakk>Q\<rbrakk>\<^sub>U"
  by (auto simp add: pred_rel_def)

lemma rel_refine_transfer [rel_transfer]: "P \<sqsubseteq> Q \<longleftrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>U \<subseteq> \<lbrakk>P\<rbrakk>\<^sub>U"
  by (auto simp add: pred_rel_def pred_refine_iff)

(* I think this law is too general to be a transfer law *)

lemma rel_pointwise_transfer (*[rel_transfer]*): "P (s, s') \<longleftrightarrow> (s, s') \<in> \<lbrakk>P\<rbrakk>\<^sub>U"
  by (auto simp: pred_rel_def)

method rel_transfer = (simp only: rel_transfer rel)

method rel_simp uses add = (rel_transfer, expr_simp add: relcomp_unfold add)
method rel_auto uses add = (rel_transfer, expr_auto add: relcomp_unfold add)

subsection \<open> Relational Properties \<close>

text \<open> We describe some properties of relations, including functional and injective relations. We
  also provide operators for extracting the domain and range of a UTP relation. \<close>

definition [rel_transfer]: "Functional P = functional \<lbrakk>P\<rbrakk>\<^sub>U"

lemma Functional_alt_def [pred]: "Functional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"
  by (rel_auto add: pred_rel_def Id_def single_valued_def)

definition [rel_transfer]: "Injective P = injective \<lbrakk>P\<rbrakk>\<^sub>U"

lemma Injective_alt_def [pred]: "Injective R \<longleftrightarrow> (Functional R \<and> II \<sqsubseteq> R ;; R\<^sup>-)"
  by (rel_auto add: pred_rel_def injective_def Id_def)

definition pre :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>1 \<Rightarrow> bool)"
  where [pred]: "pre P = (\<lambda> s. \<exists> s'. P (s, s'))"

definition post :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>2 \<Rightarrow> bool)"
  where [pred]: "post P = (\<lambda> s'. \<exists> s. P (s, s'))"

expr_ctr pre

expr_ctr post

lemma pred_pre: "pre P = (\<exists> s. P \<lbrakk>\<guillemotleft>s\<guillemotright>/\<^bold>v\<^sup>>\<rbrakk>)\<^sub><"
  by (expr_simp add: pre_def Domain_iff)

lemma pred_pre_liberate: "pre P = (P \\ out\<alpha>)\<^sub><"
  by (expr_auto add: pre_def)

lemma rel_pre [rel_transfer]: "\<lbrakk>pre P\<rbrakk>\<^sub>U = Domain \<lbrakk>P\<rbrakk>\<^sub>U"
  by (auto simp add: pre_def Domain_def pred_rel_def)

lemma rel_post [rel_transfer]: "\<lbrakk>post P\<rbrakk>\<^sub>U = Range \<lbrakk>P\<rbrakk>\<^sub>U"
  by (auto simp add: post_def Range_def pred_rel_def)

subsection \<open> Algebraic Laws \<close>

interpretation upred_semiring: semiring_1
  where times = seq and one = skip and zero = false\<^sub>h and plus = Lattices.sup
  by (unfold_locales; pred_auto add: sup_fun_def)+

declare upred_semiring.power_Suc [simp del]

text \<open> We introduce the power syntax derived from semirings. We can't use the standard @{class power},
  because this would need to apply to any relation, whereas power only applies to homogeneous relations. \<close>

abbreviation upower :: "'\<alpha> hrel \<Rightarrow> nat \<Rightarrow> '\<alpha> hrel" (infixr "\<^bold>^" 80) where
"upower P n \<equiv> upred_semiring.power P n"

translations
  "P \<^bold>^ i" <= "CONST power.power II op ;; P i"
  "P \<^bold>^ i" <= "(CONST power.power II op ;; P) i"

definition ustar :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<star>" [999] 999) where
"P\<^sup>\<star> = (\<Sqinter>i. P\<^bold>^i)"

lemma precond_equiv: "true ;; P = P \<longleftrightarrow> (in\<alpha> \<sharp> P)"
  by pred_auto

lemma precond_simp [simp]: "in\<alpha> \<sharp> P \<Longrightarrow> true ;; P = P"
  by (simp add: precond_equiv)

lemma postcond_equiv: "P ;; true = P \<longleftrightarrow> (out\<alpha> \<sharp> P)"
  by (pred_auto)

lemma postcond_simp: "out\<alpha> \<sharp> P \<Longrightarrow> P ;; true = P"
  by (simp add: postcond_equiv)

end