(* Title: Program Correctness Component Based on Kleene Algebra with Domain
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsection\<open>Component Based on Kleene Algebra with Domain\<close>

text \<open>This component supports the verification and step-wise refinement of simple while programs
in a partial correctness setting.\<close>

theory VC_KAD_scratch
  imports Main
begin

subsubsection \<open>KAD: Definitions and Basic Properties\<close>

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  by (standard, simp_all add: less_def less_eq_def add_commute, auto, metis add_assoc)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
  by (metis add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_ub: "x \<le> x + y"
  by (metis add_assoc add_idem less_eq_def)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_ub add.left_commute less_eq_def)

end

class kleene_algebra  = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class antidomain_kleene_algebra = kleene_algebra +
  fixes ad :: "'a \<Rightarrow> 'a" ("ad")
  assumes as1 [simp]: "ad x \<cdot> x = 0"
  and as2 [simp]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and as3 [simp]: "ad (ad x) + ad x = 1"

begin

definition dom_op :: "'a \<Rightarrow> 'a" ("d") where
  "d x = ad (ad x)"

lemma a_subid_aux: "ad x \<cdot> y \<le> y"
  by (metis add_commute add_ub as3 mult_1_left mult_isor)

lemma d1_a [simp]: "d x \<cdot> x = x"
  by (metis add_commute dom_op_def add_zerol as1 as3 distrib_right mult_1_left)

lemma a_idem [simp]: "ad x \<cdot> ad x = ad x"
  by (metis a_d_closed d1_a)

lemma meet_ord: "ad x \<le> ad y \<longleftrightarrow> ad x \<cdot> ad y = ad x"
  by (metis a_d_closed a_subid_aux d1_a order.antisym mult_1_right mult_isol)

lemma d_wloc: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
  by (metis a_subid_aux d1_a dom_op_def add_ub order.antisym as1 as2 mult_1_right mult_assoc)

lemma gla_1: "ad x \<cdot> y = 0 \<Longrightarrow> ad x \<le> ad y"
  by (metis a_subid_aux d_wloc dom_op_def add_zerol as3 distrib_left mult_1_right)

lemma a2_eq [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
  by (metis a_mul_d d1_a dom_op_def gla_1 add_ub order.antisym as1 as2 mult_assoc)

lemma a_supdist: "ad (x + y) \<le> ad x"
  by (metis add_commute gla_1 add_ub add_zerol as1 distrib_left less_eq_def)

lemma a_antitone: "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  by (metis a_supdist less_eq_def)

lemma a_comm: "ad x \<cdot> ad y = ad y \<cdot> ad x"
proof -
{ fix x y
  have "ad x \<cdot> ad y = d (ad x \<cdot> ad y) \<cdot> ad x \<cdot> ad y"
    by (simp add: mult_assoc)
  also have "... \<le> d (ad y) \<cdot> ad x"
    by (metis a_antitone a_d_closed a_subid_aux mult_oner a_subid_aux dom_op_def mult_isol mult_isor meet_ord)
  finally have "ad x \<cdot> ad y \<le> ad y \<cdot> ad x"
    by simp }
  thus ?thesis
    by (simp add: order.antisym)
qed

lemma a_closed [simp]: "d (ad x \<cdot> ad y) = ad x \<cdot> ad y"
proof -
  have f1: "\<And>x y. ad x \<le> ad (ad y \<cdot> x)"
    by (simp add: a_antitone a_subid_aux)
  have "\<And>x y. d (ad x \<cdot> y) \<le> ad x"
    by (metis a2_eq a_antitone a_comm a_d_closed dom_op_def f1)
  hence "\<And>x y. d (ad x \<cdot> y) \<cdot> y = ad x \<cdot> y"
    by (metis d1_a dom_op_def meet_ord mult_assoc)
  thus ?thesis
    by (metis a_comm a_idem dom_op_def)
qed

lemma d1_sum_var: "x + y \<le> (d x + d y) \<cdot> (x + y)"
proof -
  have "x + y = d x \<cdot> x + d y \<cdot> y"
    by simp
  also have "... \<le> (d x + d y) \<cdot> x + (d x + d y) \<cdot> y"
    by (metis add_commute add_lub add_ub combine_common_factor)
  finally show ?thesis
    by (simp add: distrib_left)
qed

lemma a4: "ad (x + y) = ad x \<cdot> ad y"
proof (rule order.antisym)
  show "ad (x + y) \<le> ad x \<cdot> ad y"
    by (metis a_supdist add_commute mult_isor meet_ord)
  hence "ad x \<cdot> ad y = ad x \<cdot> ad y + ad (x + y)"
    using less_eq_def add_commute by simp
  also have "... = ad (ad (ad x \<cdot> ad y) \<cdot> (x + y))"
    by (metis a_closed a_exp)
  finally show "ad x \<cdot> ad y \<le> ad (x + y)"
    using a_antitone d1_sum_var dom_op_def by auto
qed

lemma kat_prop: "d x \<cdot> y \<le> y \<cdot> d z \<longleftrightarrow> d x \<cdot> y \<cdot> ad z = 0"
proof
  show  "d x \<cdot> y \<le> y \<cdot> d z \<Longrightarrow> d x \<cdot> y \<cdot> ad z = 0"
    by (metis add_commute dom_op_def add_zerol annir as1 less_eq_def mult_isor mult_assoc)
next
  assume h: "d x \<cdot> y \<cdot> ad z = 0"
  hence "d x \<cdot> y = d x \<cdot> y \<cdot> d z + d x \<cdot> y \<cdot> ad z"
    by (metis dom_op_def as3 distrib_left mult_1_right)
  thus  "d x \<cdot> y \<le> y \<cdot> d z"
    by (metis a_subid_aux add_commute dom_op_def h add_zerol mult_assoc)
qed

lemma shunt: "ad x \<le> ad y + ad z \<longleftrightarrow> ad x \<cdot> d y \<le> ad z"
proof
  assume "ad x \<le> ad y + ad z"
  hence "ad x \<cdot> d y \<le> ad y \<cdot> d y + ad z \<cdot> d y"
    by (metis distrib_right mult_isor)
  thus " ad x \<cdot> d y \<le> ad z"
    by (metis a_closed a_d_closed a_exp a_mul_d a_supdist dom_op_def dual_order.trans less_eq_def)
next
  assume h: "ad x \<cdot> d y \<le> ad z"
  have "ad x = ad x \<cdot> ad y + ad x \<cdot> d y"
    by (metis add_commute dom_op_def as3 distrib_left mult_1_right)
  also have "... \<le> ad x \<cdot> ad y + ad z"
    using h add_lub dual_order.trans by blast
  also have "... \<le> ad y + ad z"
    by (metis a_subid_aux add_commute add_lub add_ub dual_order.trans)
  finally show "ad x \<le> ad y + ad z"
    by simp
qed

subsubsection \<open>wp Calculus\<close>

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (d p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

definition wp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "wp x p = ad (x \<cdot> ad p)"

lemma demod: " d p \<le> wp x q \<longleftrightarrow> d p \<cdot> x \<le> x \<cdot> d q"
  by (metis as1 dom_op_def gla_1 kat_prop meet_ord mult_assoc wp_def)

lemma wp_weaken: "wp x p \<le> wp (x \<cdot> ad q) (d p \<cdot> ad q)"
  by (metis a4 a_antitone a_d_closed a_mul_d dom_op_def gla_1 mult_isol mult_assoc wp_def)

lemma wp_seq [simp]: "wp (x \<cdot> y) q = wp x (wp y q)"
  using a2_eq dom_op_def mult_assoc wp_def by auto

lemma wp_seq_var: "p \<le> wp x r \<Longrightarrow> r \<le> wp y q \<Longrightarrow> p \<le> wp (x \<cdot> y) q"
proof -
  assume a1: "p \<le> wp x r"
  assume a2: "r \<le> wp y q"
  have "\<forall>z. \<not> wp x r \<le> z \<or> p \<le> z"
    using a1 dual_order.trans by blast
  then show ?thesis
    using a2 a_antitone mult_isol wp_def wp_seq by auto
qed

lemma wp_cond_var [simp]: "wp (if p then x else y fi) q = (ad p + wp x q) \<cdot> (d p + wp y q)"
  using a4 a_d_closed dom_op_def if_then_else_def distrib_right mult_assoc wp_def by auto

lemma wp_cond_aux1 [simp]: "d p \<cdot> wp (if p then x else y fi) q = d p \<cdot> wp x q"
proof -
  have "d p \<cdot> wp (if p then x else y fi) q = ad (ad p) \<cdot> (ad p + wp x q) \<cdot> (d p + wp y q)"
    using dom_op_def mult.semigroup_axioms semigroup.assoc wp_cond_var by fastforce
  also have "... = wp x q \<cdot> d p \<cdot> (d p + d (wp y q))"
    using a_comm a_d_closed dom_op_def distrib_left wp_def by auto
  also have "... = wp x q \<cdot> d p"
    by (metis a_exp dom_op_def add_ub meet_ord mult_assoc)
  finally show ?thesis
    by (simp add: a_comm dom_op_def wp_def)
qed

lemma wp_cond_aux2 [simp]: "ad p \<cdot> wp (if p then x else y fi) q = ad p \<cdot> wp y q"
  by (metis (no_types) abel_semigroup.commute if_then_else_def a_d_closed add.abel_semigroup_axioms dom_op_def wp_cond_aux1)

lemma wp_cond [simp]: "wp (if p then x else y fi) q = (d p \<cdot> wp x q) + (ad p \<cdot> wp y q)"
  by (metis as3 distrib_right dom_op_def mult_1_left wp_cond_aux2 wp_cond_aux1)

lemma wp_star_induct_var: "d q \<le> wp x q \<Longrightarrow> d q \<le> wp (x\<^sup>\<star>) q"
  using demod star_sim by blast

lemma wp_while: "d p \<cdot> d r \<le> wp x p \<Longrightarrow> d p \<le> wp (while r do x od) (d p \<cdot> ad r)"
proof -
  assume "d p \<cdot> d r \<le> wp x p"
  hence "d p \<le> wp (d r \<cdot> x) p"
    using dom_op_def mult.semigroup_axioms semigroup.assoc shunt wp_def by fastforce
  hence "d p \<le> wp ((d r \<cdot> x)\<^sup>\<star>) p"
    using wp_star_induct_var by blast
  thus ?thesis
    by (simp add: while_def) (use local.dual_order.trans wp_weaken in fastforce)
qed

lemma wp_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (while r inv i do x od) q"
proof -
  assume a1: "d p \<le> d i" and a2: "d i \<cdot> ad r \<le> d q" and "d i \<cdot> d r \<le> wp x i"
  hence "d i \<le> wp (while r inv i do x od) (d i \<cdot> ad r)"
    by (simp add: while_inv_def wp_while)
  also have "... \<le>  wp (while r inv i do x od) q"
    by (metis a2 a_antitone a_d_closed dom_op_def mult_isol wp_def)
  finally show ?thesis
    using a1 dual_order.trans by blast
qed

lemma wp_while_inv_break: "d p \<le> wp y i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (y \<cdot> (while r inv i do x od)) q"
  by (metis dom_op_def eq_refl mult_1_left mult_1_right wp_def wp_seq wp_seq_var wp_while_inv)

end

subsubsection \<open>Soundness and Relation KAD\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)"
  by (standard, auto)

lemma (in dioid) pow_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  by (metis local.dual_order.trans local.mult_isol mult_assoc)

lemma (in dioid) pow_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  proof -
    fix i
    assume "z \<cdot> x ^ i \<le> y" "z \<le> y" "y \<cdot> x \<le> y"
    hence "(z \<cdot> x ^ i) \<cdot> x \<le> y"
      using local.dual_order.trans local.mult_isor by blast
    thus "z \<cdot> (x \<cdot> x ^ i) \<le> y"
      by (simp add: mult_assoc local.power_commutes)
  qed

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_ad :: "'a rel \<Rightarrow> 'a rel" where
  "rel_ad R = {(x,x) | x. \<not> (\<exists>y. (x,y) \<in> R)}"

interpretation rel_aka: antidomain_kleene_algebra Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_ad
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.pow_inductl rel_star_contl SUP_least rel_d.pow_inductr rel_ad_def)

subsubsection \<open>Embedding Predicates in Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma d_p2r [simp]: "rel_aka.dom_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp: rel_aka.dom_op_def rel_ad_def)

lemma p2r_neg_hom [simp]: "rel_ad \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not>P s\<rceil>"
  by (auto simp: rel_ad_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

subsubsection \<open>Store and Assignment\<close>

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s,s (v := e s)) |s. True}"

lemma wp_assign [simp]: "rel_aka.wp (v ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (s (v := e s))\<rceil>"
  by (auto simp: rel_aka.wp_def gets_def rel_ad_def)

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_aka.dom_op \<lceil>P\<rceil> \<subseteq> rel_aka.wp X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_aka.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_aka.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsubsection \<open>Verification Example\<close>

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_aka.wp_while_inv, simp_all) using gcd_red_nat by auto

context antidomain_kleene_algebra
begin

subsubsection\<open>Propositional Hoare Logic\<close>

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> d p \<le> wp x q"

lemma H_skip: "H p 1 p"
  by (simp add: H_def dom_op_def wp_def)

lemma H_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def demod mult_isol order_trans)

lemma H_seq: "H p x r \<Longrightarrow> H r y q \<Longrightarrow> H p (x \<cdot> y) q"
  by (metis H_def a_d_closed demod dom_op_def wp_seq_var)

lemma H_cond: "H (d p \<cdot> d r) x q \<Longrightarrow> H (d p \<cdot> ad r) y q \<Longrightarrow> H p (if r then x else y fi) q"
proof -
  assume  h1: "H (d p \<cdot> d r) x q" and h2: "H (d p \<cdot> ad r) y q"
  hence h3: "d p \<cdot> d r \<le> wp x q" and h4: "d p \<cdot> ad r \<le> wp y q"
    using H_def a_closed dom_op_def apply auto[1]
    using H_def h2 a_closed dom_op_def by auto
  hence h5: "d p  \<le> ad r + wp x q" and h6: "d p  \<le> d r + wp y q"
    apply (simp add: dom_op_def shunt wp_def)
    using h4 a_d_closed dom_op_def shunt wp_def by auto
  hence "d p \<le> d p  \<cdot> (d r + wp y q)"
    by (metis a_idem distrib_left dom_op_def less_eq_def)
  also have  "... \<le> (ad r + wp x q) \<cdot> (d r + wp y q)"
    by (simp add: h5 mult_isor)
  finally show ?thesis
    by (simp add: H_def)
qed

lemma H_loop: "H (d p \<cdot> d r) x p \<Longrightarrow> H p (while r do x od) (d p \<cdot> ad r)"
  by (metis (full_types) H_def a_closed dom_op_def wp_while)

lemma H_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> H (d i \<cdot> d r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  using H_def a_closed dom_op_def wp_while_inv by auto

end

subsubsection\<open>Definition of Refinement KAD\<close>

class rkad = antidomain_kleene_algebra +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R_def: "x \<le> R p q \<longleftrightarrow> d p \<le> wp x q"

begin

subsubsection \<open>Propositional Refinement Calculus\<close>

lemma HR: "H p x q \<longleftrightarrow> x \<le> R p q"
  by (simp add: H_def R_def)

lemma wp_R2: "x \<le> R (wp x q) q"
  by (simp add: R_def wp_def)

lemma wp_R3: "d p \<le> wp x q \<Longrightarrow> x \<le> R p q"
  by (simp add: R_def)

lemma H_R1: "H p (R p q) q"
  by (simp add: HR)

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_R2 H_skip)

lemma R_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_R1 H_R2 H_cons)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_R1 H_R2 H_seq by blast

lemma R_cond: "if v then (R (d v \<cdot> d p) q) else (R (ad v \<cdot> d p) q) fi \<le> R p q"
  by (simp add: H_R1 H_R2 H_cond a_comm dom_op_def)

lemma R_loop: "while q do (R (d p \<cdot> d q) p) od \<le> R p (d p \<cdot> ad q)"
  by (simp add: H_R1 H_R2 H_loop)

end

subsubsection \<open>Soundness and Relation RKAD\<close>

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_aka.dom_op P \<subseteq> rel_aka.wp X Q}"

interpretation rel_rkad: rkad Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_ad rel_R
  by (standard, auto simp: rel_R_def rel_aka.dom_op_def rel_ad_def rel_aka.wp_def, blast)

subsubsection \<open>Assignment Laws\<close>

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (auto simp: rel_rkad.R_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_aka.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: rel_aka.H_def rel_aka.dom_op_def rel_ad_def gets_def rel_aka.wp_def)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq) defer
  by (erule H_assign_var, simp add: rel_rkad.H_R1)

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq, erule H_assign_var, simp add: rel_rkad.H_R1)

subsubsection \<open>Refinement Example\<close>

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkad.R_skip  by fastforce

end


theory T132
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


chapter \<open>Truth in a Standard Model\<close>

text \<open>Abstract notion of standard model and truth.\<close>

(*<*)
theory Standard_Model imports Deduction
begin
(*>*)

text \<open>First some minimal assumptions, involving
implication, negation and (universal and existential) quantification:\<close>

locale Minimal_Truth =
Syntax_with_Numerals_and_Connectives_False_Disj
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
+
\<comment> \<open>The notion of truth for sentences:\<close>
fixes isTrue :: "'fmla \<Rightarrow> bool"
assumes
not_isTrue_fls: "\<not> isTrue fls"
and
isTrue_imp:
"\<And>\<phi> \<psi>. \<phi> \<in> fmla \<Longrightarrow> \<psi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> Fvars \<psi> = {} \<Longrightarrow>
  isTrue \<phi> \<Longrightarrow> isTrue (imp \<phi> \<psi>) \<Longrightarrow> isTrue \<psi>"
and
isTrue_all:
"\<And>x \<phi>. x \<in> var \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {x} \<Longrightarrow>
  (\<forall> n \<in> num. isTrue (subst \<phi> n x)) \<Longrightarrow> isTrue (all x \<phi>)"
and
isTrue_exi:
"\<And>x \<phi>. x \<in> var \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {x} \<Longrightarrow>
  isTrue (exi x \<phi>) \<Longrightarrow> (\<exists> n \<in> num. isTrue (subst \<phi> n x))"
and
isTrue_neg:
"\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
  isTrue \<phi> \<or> isTrue (neg \<phi>)"
begin

lemma isTrue_neg_excl:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow>
 isTrue \<phi> \<Longrightarrow> isTrue (neg \<phi>) \<Longrightarrow> False"
  using isTrue_imp not_isTrue_fls unfolding neg_def by auto

lemma isTrue_neg_neg:
assumes "\<phi> \<in> fmla" "Fvars \<phi> = {}"
and "isTrue (neg (neg \<phi>))"
shows "isTrue \<phi>"
using assms isTrue_neg isTrue_neg_excl by fastforce

end \<comment> \<open>context @{locale  Minimal_Truth}\<close>

locale Minimal_Truth_Soundness =
Minimal_Truth
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  isTrue
+
Deduct_with_False_Disj
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv
and isTrue
+
assumes
\<comment> \<open>We assume soundness of the provability for sentences (w.r.t. truth):\<close>
sound_isTrue: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv \<phi> \<Longrightarrow> isTrue \<phi>"
begin

text \<open>For sound theories, consistency is a fact rather than a hypothesis:\<close>
lemma consistent: consistent
  unfolding consistent_def using not_isTrue_fls sound_isTrue by blast

lemma prv_neg_excl:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv \<phi> \<Longrightarrow> prv (neg \<phi>) \<Longrightarrow> False"
using isTrue_neg_excl[of \<phi>] sound_isTrue by auto

text \<open>Sound theories are not only consistent, but also $\omega$-consistent
(in the strong, intuitionistic sense):\<close>

lemma \<omega>consistent: \<omega>consistent
unfolding \<omega>consistent_def proof (safe del: notI)
  fix \<phi> x assume 0[simp,intro]: "\<phi> \<in> fmla"  "x \<in> var" and 1: "Fvars \<phi> = {x}"
  and 00: "\<forall>n\<in>num. prv (neg (subst \<phi> n x))"
  hence "\<forall>n\<in>num. isTrue (neg (subst \<phi> n x))"
    using 00 1 by (auto intro!: sound_isTrue)
  hence "isTrue (all x (neg \<phi>))" by (simp add: "1" isTrue_all)
  moreover
  {have "prv (imp (all x (neg \<phi>)) (neg (exi x \<phi>)))"
    using prv_all_neg_imp_neg_exi by blast
   hence "isTrue (imp (all x (neg \<phi>)) (neg (exi x \<phi>)))"
    by (simp add: "1" sound_isTrue)
  }
  ultimately have "isTrue (neg (exi x \<phi>))"
    by (metis 0 1 Diff_insert_absorb Fvars_all Fvars_exi Fvars_neg all
      exi insert_absorb insert_not_empty isTrue_imp neg)
  hence "\<not> isTrue (neg (neg (exi x \<phi>)))"
    using 1 isTrue_neg_excl by force
  thus "\<not> prv (neg (neg (exi x \<phi>)))"
    using "1" sound_isTrue by auto
qed

lemma \<omega>consistentStd1: \<omega>consistentStd1
  using \<omega>consistent \<omega>consistent_impliesStd1 by blast

lemma \<omega>consistentStd2: \<omega>consistentStd2
  using \<omega>consistent \<omega>consistent_impliesStd2 by blast

end \<comment> \<open>context @{locale Minimal_Truth_Soundness}\<close>

(*<*)
end
(*>*)


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

section \<open>Verification of Functional Heap Sort\<close>

theory HeapFunctional
imports Heap
begin

text\<open>As we
said before, maximum element of the heap is its root. So, finding
maximum element is not difficulty. But, this element should also be
removed and remainder after deleting this element is two trees, left
and right branch of original heap. Those branches are also heaps by
the definition of the heap. To maintain consistency, branches should
be combined into one tree that satisfies heap condition:\<close>

function merge :: "'a::linorder Tree \<Rightarrow> 'a Tree \<Rightarrow> 'a Tree" where
  "merge t1 E = t1"
| "merge E t2 = t2"
| "merge (T v1 l1 r1) (T v2 l2 r2) =
     (if v1 \<ge> v2 then T v1 (merge l1 (T v2 l2 r2)) r1
      else T v2 (merge l2 (T v1 l1 r1)) r2)"
by (pat_completeness) auto
termination
proof (relation "measure (\<lambda> (t1, t2). size t1 + size t2)")
  fix v1 l1 r1 v2 l2 r2
  assume "v2 \<le> v1"
  thus "((l1, T v2 l2 r2), T v1 l1 r1, T v2 l2 r2) \<in>
        measure (\<lambda>(t1, t2). Heap.size t1 + Heap.size t2)"
    by auto
next
  fix v1 l1 r1 v2 l2 r2
  assume "\<not> v2 \<le> v1"
  thus "((l2, T v1 l1 r1), T v1 l1 r1, T v2 l2 r2) \<in>
        measure (\<lambda>(t1, t2). Heap.size t1 + Heap.size t2)"
    by auto
qed simp

lemma merge_val:
  "val(merge l r) = val l \<or> val(merge l r) = val r"
proof(induct l r rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 r)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case True
    hence "val (merge (T v1 l1 r1) (T v2 l2 r2)) = val (T v1 l1 r1)"
      by auto
    thus ?thesis
      by auto
  next
    case False
    hence "val (merge (T v1 l1 r1) (T v2 l2 r2)) = val (T v2 l2 r2)"
      by auto
    thus ?thesis
      by auto
  qed
qed

text\<open>Function {\em merge} merges two heaps into one:\<close>

lemma merge_heap_is_heap:
  assumes "is_heap l" "is_heap r"
  shows "is_heap (merge l r)"
using assms
proof(induct l r rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 r)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case True
    have "is_heap l1"
      using \<open>is_heap (T v1 l1 r1)\<close>
      by (metis Tree.exhaust is_heap.simps(1) is_heap.simps(4) is_heap.simps(5))
    hence "is_heap (merge l1 (T v2 l2 r2))"
      using True \<open>is_heap (T v2 l2 r2)\<close>  3
      by auto
    have "val (merge l1 (T v2 l2 r2)) = val l1 \<or> val(merge l1 (T v2 l2 r2)) = v2"
      using merge_val[of l1 "T v2 l2 r2"]
      by auto
    show ?thesis
    proof(cases "r1 = E")
      case True
      show ?thesis
      proof(cases "l1 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v1 (T v2 l2 r2) E"
          using \<open>r1 = E\<close> \<open>v2 \<le> v1\<close>
          by auto
        thus ?thesis
          using 3
          using \<open>v2 \<le> v1\<close>
          by auto
      next
        case False
        hence "v1 \<ge> val l1"
          using 3(3)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        thus ?thesis
          using \<open>r1 = E\<close> \<open>v1 \<ge> v2\<close>
          using \<open>val (merge l1 (T v2 l2 r2)) = val l1
                     \<or> val(merge l1 (T v2 l2 r2)) = v2\<close>
          using \<open>is_heap (merge l1 (T v2 l2 r2))\<close>
          by (metis False Tree.exhaust is_heap.simps(2)
              is_heap.simps(4) merge.simps(3) val.simps)
      qed
    next
      case False
      hence "v1 \<ge> val r1"
        using 3(3)
        by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
      show ?thesis
      proof(cases "l1 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v1 (T v2 l2 r2) r1"
          using \<open>v2 \<le> v1\<close>
          by auto
        thus ?thesis
          using 3 \<open>v1 \<ge> val r1\<close>
          using \<open>v2 \<le> v1\<close>
          by (metis False Tree.exhaust Tree.inject Tree.simps(3)
              True is_heap.simps(3) is_heap.simps(6) merge.simps(2)
              merge.simps(3) order_eq_iff val.simps)
      next
        case False
        hence "v1 \<ge> val l1"
          using 3(3)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        have "merge l1 (T v2 l2 r2) \<noteq> E"
          using False
          by (metis Tree.exhaust Tree.simps(2) merge.simps(3))
        have "is_heap r1"
          using 3(3)
          by (metis False Tree.exhaust \<open>r1 \<noteq> E\<close> is_heap.simps(5))
        obtain ll1 lr1 lv1 where "r1 = T lv1 ll1 lr1"
          using \<open>r1 \<noteq> E\<close>
          by (metis Tree.exhaust)
        obtain rl1 rr1 rv1 where "merge l1 (T v2 l2 r2) = T rv1 rl1 rr1"
          using \<open>merge l1 (T v2 l2 r2) \<noteq> E\<close>
          by (metis Tree.exhaust)
        have "val (merge l1 (T v2 l2 r2)) \<le> v1"
          using \<open>val (merge l1 (T v2 l2 r2)) = val l1 \<or>
                 val(merge l1 (T v2 l2 r2)) = v2\<close>
          using \<open>v1 \<ge> v2\<close> \<open>v1 \<ge> val l1\<close>
          by auto
        hence "is_heap (T v1 (merge l1 (T v2 l2 r2)) r1)"
          using is_heap.simps(5)[of v1 lv1 ll1 lr1 rv1 rl1  rr1]
          using \<open>r1 = T lv1 ll1 lr1\<close> \<open>merge l1 (T v2 l2 r2) = T rv1 rl1 rr1\<close>
          using \<open>is_heap r1\<close> \<open>is_heap (merge l1 (T v2 l2 r2))\<close> \<open>v1 \<ge> val r1\<close>
          by auto
        thus ?thesis
          using \<open>v2 \<le> v1\<close>
          by auto
      qed
    qed
  next
    case False
    have "is_heap l2"
      using 3(4)
      by (metis Tree.exhaust is_heap.simps(1)
          is_heap.simps(4) is_heap.simps(5))
    hence "is_heap (merge l2 (T v1 l1 r1))"
      using False \<open>is_heap (T v1 l1 r1)\<close>  3
      by auto
    have "val (merge l2 (T v1 l1 r1)) = val l2 \<or>
          val(merge l2 (T v1 l1 r1)) = v1"
      using merge_val[of l2 "T v1 l1 r1"]
      by auto
    show ?thesis
    proof(cases "r2 = E")
      case True
      show ?thesis
      proof(cases "l2 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v2 (T v1 l1 r1) E"
          using \<open>r2 = E\<close> \<open>\<not> v2 \<le> v1\<close>
          by auto
        thus ?thesis
          using 3
          using \<open>\<not> v2 \<le> v1\<close>
          by auto
      next
        case False
        hence "v2 \<ge> val l2"
          using 3(4)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        thus ?thesis
          using \<open>r2 = E\<close> \<open>\<not> v1 \<ge> v2\<close>
          using \<open>is_heap (merge l2 (T v1 l1 r1))\<close>
          using \<open>val (merge l2 (T v1 l1 r1)) = val l2 \<or>
                 val(merge l2 (T v1 l1 r1)) = v1\<close>
          by (metis False Tree.exhaust is_heap.simps(2)
              is_heap.simps(4) linorder_linear merge.simps(3) val.simps)
      qed
    next
      case False
      hence "v2 \<ge> val r2"
        using 3(4)
        by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
      show ?thesis
      proof(cases "l2 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v2 (T v1 l1 r1) r2"
          using \<open>\<not> v2 \<le> v1\<close>
          by auto
        thus ?thesis
          using 3 \<open>v2 \<ge> val r2\<close>
          using \<open>\<not> v2 \<le> v1\<close>
          by (metis False Tree.exhaust Tree.simps(3) is_heap.simps(3)
              is_heap.simps(5) linorder_linear val.simps)
      next
        case False
        hence "v2 \<ge> val l2"
          using 3(4)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        have "merge l2 (T v1 l1 r1) \<noteq> E"
          using False
          by (metis Tree.exhaust Tree.simps(2) merge.simps(3))
        have "is_heap r2"
          using 3(4)
          by (metis False Tree.exhaust \<open>r2 \<noteq> E\<close> is_heap.simps(5))
        obtain ll1 lr1 lv1 where "r2 = T lv1 ll1 lr1"
          using \<open>r2 \<noteq> E\<close>
          by (metis Tree.exhaust)
        obtain rl1 rr1 rv1 where "merge l2 (T v1 l1 r1) = T rv1 rl1 rr1"
          using \<open>merge l2 (T v1 l1 r1) \<noteq> E\<close>
          by (metis Tree.exhaust)
        have "val (merge l2 (T v1 l1 r1)) \<le> v2"
          using \<open>val (merge l2 (T v1 l1 r1)) = val l2 \<or>
                 val(merge l2 (T v1 l1 r1)) = v1\<close>
          using \<open>\<not> v1 \<ge> v2\<close> \<open>v2 \<ge> val l2\<close>
          by auto
        hence "is_heap (T v2 (merge l2 (T v1 l1 r1)) r2)"
          using is_heap.simps(5)[of v1 lv1 ll1 lr1 rv1 rl1 rr1]
          using \<open>r2 = T lv1 ll1 lr1\<close> \<open>merge l2 (T v1 l1 r1) = T rv1 rl1 rr1\<close>
          using \<open>is_heap r2\<close> \<open>is_heap (merge l2 (T v1 l1 r1))\<close> \<open>v2 \<ge> val r2\<close>
          by auto
        thus ?thesis
          using \<open>\<not> v2 \<le> v1\<close>
          by auto
      qed
    qed
  qed
qed

definition insert :: "'a::linorder \<Rightarrow> 'a Tree \<Rightarrow> 'a Tree" where
  "insert v t =  merge t (T v E E)"

primrec hs_of_list where
  "hs_of_list [] = E"
| "hs_of_list (v # l) = insert v (hs_of_list l)"

definition hs_is_empty where
[simp]: "hs_is_empty t \<longleftrightarrow>  t = E"

text\<open>Definition of function {\em remove\_max}:\<close>

fun hs_remove_max:: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree"  where
  "hs_remove_max (T v l r) = (v, merge l r)"

lemma merge_multiset:
  "multiset l + multiset g = multiset (merge l g)"
proof(induct l g rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 g)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case  True
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset (merge l1 (T v2 l2 r2)) +  multiset r1"
      by auto
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset l1 + multiset (T v2 l2 r2) + multiset r1"
      using 3 True
      by (metis union_assoc)
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset l1 + multiset r1 + multiset (T v2 l2 r2)"
      by (metis union_commute union_lcomm)
    thus ?thesis
      by auto
  next
    case False
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v2#} + multiset (merge l2 (T v1 l1 r1)) + multiset r2"
      by auto
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v2#} + multiset l2 + multiset r2 +  multiset (T v1 l1 r1)"
      using 3 False
      by (metis union_commute union_lcomm)
    thus ?thesis
      by (metis multiset.simps(2) union_commute)
  qed
qed

text\<open>Proof that defined functions are interpretation of abstract functions from locale {\em Collection}:\<close>

interpretation HS: Collection "E" hs_is_empty hs_of_list multiset
proof
   fix t
  assume "hs_is_empty t"
  thus "t = E"
    by auto
next
  show "hs_is_empty E"
    by auto
next
  show "multiset E = {#}"
    by auto
next
  fix l
  show "multiset (hs_of_list l) = mset l"
  proof(induct l)
    case Nil
    thus ?case
      by auto
  next
    case (Cons a l)
    have "multiset (hs_of_list (a # l)) = multiset (hs_of_list l) + {#a#}"
      using merge_multiset[of "hs_of_list l" "T a E E"]
      apply auto
      unfolding insert_def
      by auto
    thus ?case
      using Cons
      by auto
  qed
qed

text\<open>Proof that defined functions are interpretation of abstract functions from locale {\em Heap}:\<close>

interpretation Heap "E" hs_is_empty hs_of_list multiset id hs_remove_max
proof
  fix l
  show "multiset l = Heap.multiset (id l)"
    by auto
next
  fix l
  show "is_heap (id (hs_of_list l))"
  proof(induct l)
    case Nil
    thus ?case
      by auto
  next
    case (Cons a l)
    have "hs_of_list (a # l) = merge (hs_of_list l) (T a E E)"
      apply auto
      unfolding insert_def
      by auto
    have "is_heap (T a E E)"
      by auto
    hence "is_heap (merge (hs_of_list l) (T a E E))"
      using Cons merge_heap_is_heap[of "hs_of_list l" "T a E E"]
      by auto
    thus ?case
      using \<open>hs_of_list (a # l) = merge (hs_of_list l) (T a E E)\<close>
      by auto
  qed
next
  fix t
  show " (id t = E) = hs_is_empty t"
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  then obtain l r where "t = T m l r"
    by (metis Pair_inject Tree.exhaust hs_is_empty_def hs_remove_max.simps)
  thus "add_mset m (multiset t') = multiset t"
    using merge_multiset[of l r]
    using \<open>(m, t') = hs_remove_max t\<close>
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "is_heap (id t)" "(m, t') = hs_remove_max t"
  then obtain v l r where "t = T v l r"
    by (metis Tree.exhaust hs_is_empty_def)
  hence "t' = merge l r"
    using \<open>(m, t') = hs_remove_max t\<close>
    by auto
  have "is_heap l \<and> is_heap r"
    using \<open>is_heap (id t)\<close>
    using \<open>t = T v l r\<close>
    by (metis Tree.exhaust id_apply is_heap.simps(1)
        is_heap.simps(3) is_heap.simps(4) is_heap.simps(5))
  thus "is_heap (id t')"
    using \<open>t' = merge l r\<close>
    using merge_heap_is_heap
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  thus "m = val (id t)"
    by (metis Pair_inject Tree.exhaust hs_is_empty_def
        hs_remove_max.simps id_apply val.simps)
qed

end


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

theory Comparator
  imports Main
begin

section \<open>Comparators on linear quasi-orders\<close>

subsection \<open>Basic properties\<close>

datatype comp = Less | Equiv | Greater

locale comparator =
  fixes cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp"
  assumes refl [simp]: "\<And>a. cmp a a = Equiv"
    and trans_equiv: "\<And>a b c. cmp a b = Equiv \<Longrightarrow> cmp b c = Equiv \<Longrightarrow> cmp a c = Equiv"
  assumes trans_less: "cmp a b = Less \<Longrightarrow> cmp b c = Less \<Longrightarrow> cmp a c = Less"
    and greater_iff_sym_less: "\<And>b a. cmp b a = Greater \<longleftrightarrow> cmp a b = Less"
begin

text \<open>Dual properties\<close>

lemma trans_greater:
  "cmp a c = Greater" if "cmp a b = Greater" "cmp b c = Greater"
  using that greater_iff_sym_less trans_less by blast

lemma less_iff_sym_greater:
  "cmp b a = Less \<longleftrightarrow> cmp a b = Greater"
  by (simp add: greater_iff_sym_less)

text \<open>The equivalence part\<close>

lemma sym:
  "cmp b a = Equiv \<longleftrightarrow> cmp a b = Equiv"
  by (metis (full_types) comp.exhaust greater_iff_sym_less)

lemma reflp:
  "reflp (\<lambda>a b. cmp a b = Equiv)"
  by (rule reflpI) simp

lemma symp:
  "symp (\<lambda>a b. cmp a b = Equiv)"
  by (rule sympI) (simp add: sym)

lemma equivp:
  "equivp (\<lambda>a b. cmp a b = Equiv)"
  using reflp symp transp by (rule equivpI)

text \<open>The strict part\<close>

lemma irreflp_less:
  "irreflp (\<lambda>a b. cmp a b = Less)"
  by (rule irreflpI) simp

lemma irreflp_greater:
  "irreflp (\<lambda>a b. cmp a b = Greater)"
  by (rule irreflpI) simp

lemma asym_less:
  "cmp b a \<noteq> Less" if "cmp a b = Less"
  using that greater_iff_sym_less by force

lemma asym_greater:
  "cmp b a \<noteq> Greater" if "cmp a b = Greater"
  using that greater_iff_sym_less by force

lemma asymp_less:
  "asymp (\<lambda>a b. cmp a b = Less)"
  using irreflp_less by (auto intro: asympI dest: asym_less)

lemma asymp_greater:
  "asymp (\<lambda>a b. cmp a b = Greater)"
  using irreflp_greater by (auto intro!: asympI dest: asym_greater)

lemma trans_equiv_less:
  "cmp a c = Less" if "cmp a b = Equiv" and "cmp b c = Less"
  using that
  by (metis (full_types) comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_less_equiv:
  "cmp a c = Less" if "cmp a b = Less" and "cmp b c = Equiv"
  using that
  by (metis (full_types) comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_equiv_greater:
  "cmp a c = Greater" if "cmp a b = Equiv" and "cmp b c = Greater"
  using that by (simp add: sym [of a b] greater_iff_sym_less trans_less_equiv)

lemma trans_greater_equiv:
  "cmp a c = Greater" if "cmp a b = Greater" and "cmp b c = Equiv"
  using that by (simp add: sym [of b c] greater_iff_sym_less trans_equiv_less)

lemma transp_less:
  "transp (\<lambda>a b. cmp a b = Less)"
  by (rule transpI) (fact trans_less)

lemma transp_greater:
  "transp (\<lambda>a b. cmp a b = Greater)"
  by (rule transpI) (fact trans_greater)

text \<open>The reflexive part\<close>

lemma reflp_not_less:
  "reflp (\<lambda>a b. cmp a b \<noteq> Less)"
  by (rule reflpI) simp

lemma reflp_not_greater:
  "reflp (\<lambda>a b. cmp a b \<noteq> Greater)"
  by (rule reflpI) simp

lemma quasisym_not_less:
  "cmp a b = Equiv" if "cmp a b \<noteq> Less" and "cmp b a \<noteq> Less"
  using that comp.exhaust greater_iff_sym_less by auto

lemma quasisym_not_greater:
  "cmp a b = Equiv" if "cmp a b \<noteq> Greater" and "cmp b a \<noteq> Greater"
  using that comp.exhaust greater_iff_sym_less by auto

lemma trans_not_less:
  "cmp a c \<noteq> Less" if "cmp a b \<noteq> Less" "cmp b c \<noteq> Less"
  using that by (metis comp.exhaust greater_iff_sym_less trans_equiv trans_less)

lemma trans_not_greater:
  "cmp a c \<noteq> Greater" if "cmp a b \<noteq> Greater" "cmp b c \<noteq> Greater"
  using that greater_iff_sym_less trans_not_less by blast

lemma transp_not_less:
  "transp (\<lambda>a b. cmp a b \<noteq> Less)"
  by (rule transpI) (fact trans_not_less)

lemma transp_not_greater:
  "transp (\<lambda>a b. cmp a b \<noteq> Greater)"
  by (rule transpI) (fact trans_not_greater)

text \<open>Substitution under equivalences\<close>

lemma equiv_subst_left:
  "cmp z y = comp \<longleftrightarrow> cmp x y = comp" if "cmp z x = Equiv" for comp
proof -
  from that have "cmp x z = Equiv"
    by (simp add: sym)
  with that show ?thesis
    by (cases comp) (auto intro: trans_equiv trans_equiv_less trans_equiv_greater)
qed

lemma equiv_subst_right:
  "cmp x z = comp \<longleftrightarrow> cmp x y = comp" if "cmp z y = Equiv" for comp
proof -
  from that have "cmp y z = Equiv"
    by (simp add: sym)
  with that show ?thesis
    by (cases comp) (auto intro: trans_equiv trans_less_equiv trans_greater_equiv)
qed

end

typedef 'a comparator = "{cmp :: 'a \<Rightarrow> 'a \<Rightarrow> comp. comparator cmp}"
  morphisms compare Abs_comparator
proof -
  have "comparator (\<lambda>_ _. Equiv)"
    by standard simp_all
  then show ?thesis
    by auto
qed

setup_lifting type_definition_comparator

global_interpretation compare: comparator "compare cmp"
  using compare [of cmp] by simp

lift_definition flat :: "'a comparator"
  is "\<lambda>_ _. Equiv" by standard simp_all

instantiation comparator :: (linorder) default
begin

lift_definition default_comparator :: "'a comparator"
  is "\<lambda>x y. if x < y then Less else if x > y then Greater else Equiv"
  by standard (auto split: if_splits)

instance ..

end

text \<open>A rudimentary quickcheck setup\<close>

instantiation comparator :: (enum) equal
begin

lift_definition equal_comparator :: "'a comparator \<Rightarrow> 'a comparator \<Rightarrow> bool"
  is "\<lambda>f g. \<forall>x \<in> set Enum.enum. f x = g x" .

instance
  by (standard; transfer) (auto simp add: enum_UNIV)

end

lemma [code nbe]:
  "HOL.equal (cmp :: 'a::enum comparator) cmp \<longleftrightarrow> True"
  by (fact equal_refl)

instantiation comparator :: ("{linorder, typerep}") full_exhaustive
begin

definition full_exhaustive_comparator ::
  "('a comparator \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
    \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where "full_exhaustive_comparator f s =
    Quickcheck_Exhaustive.orelse
      (f (flat, (\<lambda>u. Code_Evaluation.Const (STR ''Comparator.flat'') TYPEREP('a comparator))))
      (f (default, (\<lambda>u. Code_Evaluation.Const (STR ''HOL.default_class.default'') TYPEREP('a comparator))))"

instance ..

end

subsection \<open>Fundamental comparator combinators\<close>

lift_definition reversed :: "'a comparator \<Rightarrow> 'a comparator"
  is "\<lambda>cmp a b. cmp b a"
proof -
  fix cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp"
  assume "comparator cmp"
  then interpret comparator cmp .
  show "comparator (\<lambda>a b. cmp b a)"
    by standard (auto intro: trans_equiv trans_less simp: greater_iff_sym_less)
qed

lift_definition key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a comparator \<Rightarrow> 'b comparator"
  is "\<lambda>f cmp a b. cmp (f a) (f b)"
proof -
  fix cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp" and f :: "'b \<Rightarrow> 'a"
  assume "comparator cmp"
  then interpret comparator cmp .
  show "comparator (\<lambda>a b. cmp (f a) (f b))"
    by standard (auto intro: trans_equiv trans_less simp: greater_iff_sym_less)
qed

subsection \<open>Direct implementations for linear orders on selected types\<close>

definition comparator_bool :: "bool comparator"
  where [simp, code_abbrev]: "comparator_bool = default"

lemma compare_comparator_bool [code abstract]:
  "compare comparator_bool = (\<lambda>p q.
    if p then if q then Equiv else Greater
    else if q then Less else Equiv)"
  by (auto simp add: fun_eq_iff) (transfer; simp)+

definition raw_comparator_nat :: "nat \<Rightarrow> nat \<Rightarrow> comp"
  where [simp]: "raw_comparator_nat = compare default"

lemma default_comparator_nat [simp, code]:
  "raw_comparator_nat (0::nat) 0 = Equiv"
  "raw_comparator_nat (Suc m) 0 = Greater"
  "raw_comparator_nat 0 (Suc n) = Less"
  "raw_comparator_nat (Suc m) (Suc n) = raw_comparator_nat m n"
  by (transfer; simp)+

definition comparator_nat :: "nat comparator"
  where [simp, code_abbrev]: "comparator_nat = default"

lemma compare_comparator_nat [code abstract]:
  "compare comparator_nat = raw_comparator_nat"
  by simp

definition comparator_linordered_group :: "'a::linordered_ab_group_add comparator"
  where [simp, code_abbrev]: "comparator_linordered_group = default"

lemma comparator_linordered_group [code abstract]:
  "compare comparator_linordered_group = (\<lambda>a b.
    let c = a - b in if c < 0 then Less
    else if c = 0 then Equiv else Greater)"
proof (rule ext)+
  fix a b :: 'a
  show "compare comparator_linordered_group a b =
    (let c = a - b in if c < 0 then Less
       else if c = 0 then Equiv else Greater)"
    by (simp add: Let_def not_less) (transfer; auto)
qed

end