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

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

header "The Algebra of pGCL"

theory Algebra imports WellDefined begin

text_raw {* \label{s:Algebra} *}

text {* Programs in pGCL have a rich algebraic structure, largely mirroring that for GCL. We show
that programs form a lattice under refinement, with @{term "a \<Sqinter> b"} and @{term "a \<Squnion> b"} as the meet
and join operators, respectively. We also take advantage of the algebraic structure to establish a
framwork for the modular decomposition of proofs. *}

subsection {* Program Refinement *}

text_raw {* \label{s:progref} *}

text {* Refinement in pGCL relates to refinement in GCL exactly as probabilistic entailment relates
to implication. It turns out to have a very similar algebra, the rules of which we establish
shortly. *}

definition
  refines :: "'s prog \<Rightarrow> 's prog \<Rightarrow> bool" (infix "\<sqsubseteq>" 70)
where
  "prog \<sqsubseteq> prog' \<equiv> \<forall>P. sound P \<longrightarrow> wp prog P \<tturnstile> wp prog' P"

lemma refinesI[intro]:
  "\<lbrakk> \<And>P. sound P \<Longrightarrow> wp prog P \<tturnstile> wp prog' P \<rbrakk> \<Longrightarrow> prog \<sqsubseteq> prog'"
  unfolding refines_def by(simp)

lemma refinesD[dest]:
  "\<lbrakk> prog \<sqsubseteq> prog'; sound P \<rbrakk> \<Longrightarrow> wp prog P \<tturnstile> wp prog' P"
  unfolding refines_def by(simp)

text {* The equivalence relation below will turn out to be that induced by refinement. It is also
the application of @{term equiv_trans} to the weakest precondition. *}

definition
  pequiv :: "'s prog \<Rightarrow> 's prog \<Rightarrow> bool" (infix "\<simeq>" 70)
where
  "prog \<simeq> prog' \<equiv> \<forall>P. sound P \<longrightarrow> wp prog P = wp prog' P"

lemma pequivI[intro]:
  "\<lbrakk> \<And>P. sound P \<Longrightarrow> wp prog P = wp prog' P \<rbrakk> \<Longrightarrow> prog \<simeq> prog'"
  unfolding pequiv_def by(simp)

lemma pequivD[dest,simp]:
  "\<lbrakk> prog \<simeq> prog'; sound P \<rbrakk> \<Longrightarrow> wp prog P = wp prog' P"
  unfolding pequiv_def by(simp)

lemma pequiv_equiv_trans:
  "a \<simeq> b \<longleftrightarrow> equiv_trans (wp a) (wp b)"
  by(auto)

subsection {* Simple Identities *}

text {* The following identities involve only the primitive operations as defined in
\autoref{s:syntax}, and refinement as defined above. *}

subsubsection {* Laws following from the basic arithmetic of the operators seperately *}

lemma DC_comm[ac_simps]:
  "a \<Sqinter> b = b \<Sqinter> a"
  unfolding DC_def by(simp add:ac_simps)

lemma DC_assoc[ac_simps]:
  "a \<Sqinter> (b \<Sqinter> c) = (a \<Sqinter> b) \<Sqinter> c"
  unfolding DC_def by(simp add:ac_simps)

lemma DC_idem:
  "a \<Sqinter> a = a"
  unfolding DC_def by(simp)

lemma AC_comm[ac_simps]:
  "a \<Squnion> b = b \<Squnion> a"
  unfolding AC_def by(simp add:ac_simps)

lemma AC_assoc[ac_simps]:
  "a \<Squnion> (b \<Squnion> c) = (a \<Squnion> b) \<Squnion> c"
  unfolding AC_def by(simp add:ac_simps)

lemma AC_idem:
  "a \<Squnion> a = a"
  unfolding AC_def by(simp)

lemma PC_quasi_comm:
  "a \<^bsub>p\<^esub>\<oplus> b = b \<^bsub>(\<lambda>s. 1 - p s)\<^esub>\<oplus> a"
  unfolding PC_def by(simp add:algebra_simps)

lemma PC_idem:
  "a \<^bsub>p\<^esub>\<oplus> a = a"
  unfolding PC_def by(simp add:algebra_simps)

lemma Seq_assoc[ac_simps]:
  "A ;; (B ;; C) = A ;; B ;; C"
  by(simp add:Seq_def o_def)

lemma Abort_refines[intro]:
  "well_def a \<Longrightarrow> Abort \<sqsubseteq> a"
  by(rule refinesI, unfold wp_eval, auto dest!:well_def_wp_healthy)

subsubsection {* Laws relating demonic choice and refinement *}

lemma left_refines_DC:
  "(a \<Sqinter> b) \<sqsubseteq> a"
  by(auto intro!:refinesI simp:wp_eval)

lemma right_refines_DC:
  "(a \<Sqinter> b) \<sqsubseteq> b"
  by(auto intro!:refinesI simp:wp_eval)

lemma DC_refines:
  fixes a::"'s prog" and b and c
  assumes rab: "a \<sqsubseteq> b" and rac: "a \<sqsubseteq> c"
  shows "a \<sqsubseteq> (b \<Sqinter> c)"
proof
  fix P::"'s \<Rightarrow> real" assume sP: "sound P"
  with assms have "wp a P \<tturnstile> wp b P" and "wp a P \<tturnstile> wp c P"
    by(auto dest:refinesD)
  thus "wp a P \<tturnstile> wp (b \<Sqinter> c) P"
    by(auto simp:wp_eval intro:min.boundedI)
qed

lemma DC_mono:
  fixes a::"'s prog"
  assumes rab: "a \<sqsubseteq> b" and rcd: "c \<sqsubseteq> d"
  shows "(a \<Sqinter> c) \<sqsubseteq> (b \<Sqinter> d)"
proof(rule refinesI, unfold wp_eval, rule le_funI)
  fix P::"'s \<Rightarrow> real" and s::'s
  assume sP: "sound P"
  with assms have "wp a P s \<le> wp b P s" and "wp c P s \<le> wp d P s"
    by(auto)
  thus "min (wp a P s) (wp c P s) \<le> min (wp b P s) (wp d P s)"
    by(auto)
qed

subsubsection {* Laws relating angelic choice and refinement *}

lemma left_refines_AC:
  "a \<sqsubseteq> (a \<Squnion> b)"
  by(auto intro!:refinesI simp:wp_eval)

lemma right_refines_AC:
  "b \<sqsubseteq> (a \<Squnion> b)"
  by(auto intro!:refinesI simp:wp_eval)

lemma AC_refines:
  fixes a::"'s prog" and b and c
  assumes rac: "a \<sqsubseteq> c" and rbc: "b \<sqsubseteq> c"
  shows "(a \<Squnion> b) \<sqsubseteq> c"
proof
  fix P::"'s \<Rightarrow> real" assume sP: "sound P"
  with assms have "\<And>s. wp a P s \<le> wp c P s"
              and "\<And>s. wp b P s \<le> wp c P s"
    by(auto dest:refinesD)
  thus "wp (a \<Squnion> b) P \<tturnstile> wp c P"
    unfolding wp_eval by(auto)
qed

lemma AC_mono:
  fixes a::"'s prog"
  assumes rab: "a \<sqsubseteq> b" and rcd: "c \<sqsubseteq> d"
  shows "(a \<Squnion> c) \<sqsubseteq> (b \<Squnion> d)"
proof(rule refinesI, unfold wp_eval, rule le_funI)
  fix P::"'s \<Rightarrow> real" and s::'s
  assume sP: "sound P"
  with assms have "wp a P s \<le> wp b P s" and "wp c P s \<le> wp d P s"
    by(auto)
  thus "max (wp a P s) (wp c P s) \<le> max (wp b P s) (wp d P s)"
    by(auto)
qed

subsubsection {* Laws depending on the arithmetic of @{term "a \<^bsub>p\<^esub>\<oplus> b"} and @{term "a \<Sqinter> b"}
together *}

lemma DC_refines_PC:
  assumes unit: "unitary p"
  shows "(a \<Sqinter> b) \<sqsubseteq> (a \<^bsub>p\<^esub>\<oplus> b)"
proof(rule refinesI, unfold wp_eval, rule le_funI)
  fix s and P::"'a \<Rightarrow> real" assume sound: "sound P"
  from unit have nn_p: "0 \<le> p s" by(blast)
  from unit have "p s \<le> 1" by(blast)
  hence nn_np: "0 \<le> 1 - p s" by(simp)
  show "min (wp a P s) (wp b P s) \<le> p s * wp a P s + (1 - p s) * wp b P s"
  proof(cases "wp a P s \<le> wp b P s",
      simp_all add:min.absorb1 min.absorb2)
    case True note le = this
    have "wp a P s = (p s + (1 - p s)) * wp a P s" by(simp)
    also have "... = p s * wp a P s + (1 - p s) * wp a P s"
      by(simp only: distrib_right)
    also {
      from le and nn_np have "(1 - p s) * wp a P s \<le> (1 - p s) * wp b P s"
        by(rule mult_left_mono)
      hence "p s * wp a P s + (1 - p s) * wp a P s \<le>
        p s * wp a P s + (1 - p s) * wp b P s"
        by(rule add_left_mono)
    }
    finally show "wp a P s \<le> p s * wp a P s + (1 - p s) * wp b P s" .
  next
    case False
    then have le: "wp b P s \<le> wp a P s" by(simp)
    have "wp b P s = (p s + (1 - p s)) * wp b P s" by(simp)
    also have "... = p s * wp b P s + (1 - p s) * wp b P s"
      by(simp only:distrib_right)
    also {
      from le and nn_p have "p s * wp b P s \<le> p s * wp a P s"
        by(rule mult_left_mono)
      hence "p s * wp b P s + (1 - p s) * wp b P s \<le>
        p s * wp a P s + (1 - p s) * wp b P s"
        by(rule add_right_mono)
    }
    finally show "wp b P s \<le> p s * wp a P s + (1 - p s) * wp b P s" .
  qed
qed

subsubsection {* Laws depending on the arithmetic of @{term "a \<^bsub>p\<^esub>\<oplus> b"} and @{term "a \<Squnion> b"}
together *}

lemma PC_refines_AC:
  assumes unit: "unitary p"
  shows "(a \<^bsub>p\<^esub>\<oplus> b) \<sqsubseteq> (a \<Squnion> b)"
proof(rule refinesI, unfold wp_eval, rule le_funI)
  fix s and P::"'a \<Rightarrow> real" assume sound: "sound P"

  from unit have "p s \<le> 1" by(blast)
  hence nn_np: "0 \<le> 1 - p s" by(simp)

  show "p s * wp a P s + (1 - p s) * wp b P s \<le>
        max (wp a P s) (wp b P s)"
  proof(cases "wp a P s \<le> wp b P s")
    case True note leab = this
    with unit nn_np
    have "p s * wp a P s + (1 - p s) * wp b P s \<le>
          p s * wp b P s + (1 - p s) * wp b P s"
      by(auto intro:add_mono mult_left_mono)
    also have "... = wp b P s"
      by(auto simp:field_simps)
    also from leab
    have "... = max (wp a P s) (wp b P s)"
      by(auto)
    finally show ?thesis .
  next
    case False note leba = this
    with unit nn_np
    have "p s * wp a P s + (1 - p s) * wp b P s \<le>
          p s * wp a P s + (1 - p s) * wp a P s"
      by(auto intro:add_mono mult_left_mono)
    also have "... = wp a P s"
      by(auto simp:field_simps)
    also from leba
    have "... = max (wp a P s) (wp b P s)"
      by(auto)
    finally show ?thesis .
  qed
qed

subsubsection {* Laws depending on the arithmetic of @{term "a \<Squnion> b"} and @{term "a \<Sqinter> b"} together
*}

lemma DC_refines_AC:
  "(a \<Sqinter> b) \<sqsubseteq> (a \<Squnion> b)"
  by(auto intro!:refinesI simp:wp_eval)

subsubsection {* Laws Involving Refinement and Equivalence *}

lemma pr_trans[trans]:
  fixes A::"'a prog"
  assumes prAB: "A \<sqsubseteq> B"
      and prBC: "B \<sqsubseteq> C"
  shows "A \<sqsubseteq> C"
proof
  fix P::"'a \<Rightarrow> real" assume sP: "sound P"
  with prAB have "wp A P \<tturnstile> wp B P" by(blast)
  also from sP and prBC have "... \<tturnstile> wp C P" by(blast)
  finally show "wp A P \<tturnstile> ..." .
qed

lemma pequiv_refl[intro!,simp]:
  "a \<simeq> a"
  by(auto)

lemma pequiv_comm[ac_simps]:
  "a \<simeq> b \<longleftrightarrow> b \<simeq> a"
  unfolding pequiv_def
  by(rule iffI, safe, simp_all)

lemma pequiv_pr[dest]:
  "a \<simeq> b \<Longrightarrow> a \<sqsubseteq> b"
  by(auto)

lemma pequiv_trans[intro,trans]:
  "\<lbrakk> a \<simeq> b; b \<simeq> c \<rbrakk> \<Longrightarrow> a \<simeq> c"
  unfolding pequiv_def by(auto intro!:order_trans)

lemma pequiv_pr_trans[intro,trans]:
  "\<lbrakk> a \<simeq> b; b \<sqsubseteq> c \<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  unfolding pequiv_def refines_def by(simp)

lemma pr_pequiv_trans[intro,trans]:
  "\<lbrakk> a \<sqsubseteq> b; b \<simeq> c \<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  unfolding pequiv_def refines_def by(simp)

text {* Refinement induces equivalence by antisymmetry: *}
lemma pequiv_antisym:
  "\<lbrakk> a \<sqsubseteq> b; b \<sqsubseteq> a \<rbrakk> \<Longrightarrow> a \<simeq> b"
  by(auto intro:antisym)

lemma pequiv_DC:
  "\<lbrakk> a \<simeq> c; b \<simeq> d \<rbrakk> \<Longrightarrow> (a \<Sqinter> b) \<simeq> (c \<Sqinter> d)"
  by(auto intro!:DC_mono pequiv_antisym simp:ac_simps)

lemma pequiv_AC:
  "\<lbrakk> a \<simeq> c; b \<simeq> d \<rbrakk> \<Longrightarrow> (a \<Squnion> b) \<simeq> (c \<Squnion> d)"
  by(auto intro!:AC_mono pequiv_antisym simp:ac_simps)

subsection {* Deterministic Programs are Maximal *}

text {* Any sub-additive refinement of a deterministic program is in fact an equivalence.
Deterministic programs are thus maximal (under the refinement order) among sub-additive programs.
*}
lemma refines_determ:
  fixes a::"'s prog"
  assumes da: "determ (wp a)"
      and wa: "well_def a"
      and wb: "well_def b"
      and dr: "a \<sqsubseteq> b"
  shows "a \<simeq> b"
  txt {* Proof by contradiction. *}
proof(rule pequivI, rule contrapos_pp)
  from wb have "feasible (wp b)" by(auto)
  with wb have sab: "sub_add (wp b)"
    by(auto dest: sublinear_subadd[OF well_def_wp_sublinear])
  fix P::"'s \<Rightarrow> real" assume sP: "sound P"
  txt {* Assume that @{term a} and @{term b} are not equivalent: *}
  assume ne: "wp a P \<noteq> wp b P"
  txt {* Find a point at which they differ.  As @{term "a \<sqsubseteq> b"},
    @{term "wp b P s"} must by strictly greater than @{term "wp a P s"}
    here: *}
  hence "\<exists>s. wp a P s < wp b P s"
  proof(rule contrapos_np)
    assume "\<not>(\<exists>s. wp a P s < wp b P s)"
    hence "\<forall>s. wp b P s \<le> wp a P s" by(auto simp:not_less)
    hence "wp b P \<tturnstile> wp a P" by(auto)
    moreover from sP dr have "wp a P \<tturnstile> wp b P" by(auto)
    ultimately show "wp a P = wp b P" by(auto)
  qed
  then obtain s where less: "wp a P s < wp b P s" by(blast)
  txt {* Take a carefully constructed expectation: *}
  let ?Pc = "\<lambda>s. bound_of P - P s"
  have sPc: "sound ?Pc"
  proof(rule soundI)
    from sP have "\<And>s. 0 \<le> P s" by(auto)
    hence "\<And>s. ?Pc s \<le> bound_of P" by(auto)
    thus "bounded ?Pc" by(blast)
    from sP have "\<And>s. P s \<le> bound_of P" by(auto)
    hence "\<And>s. 0 \<le> ?Pc s" by(auto simp:sign_simps)
    thus "nneg ?Pc" by(auto)
  qed
  txt {* We then show that @{term "wp b"} violates feasibility, and
    thus healthiness. *}
  from sP have "0 \<le> bound_of P" by(auto)
  with da have "bound_of P = wp a (\<lambda>s. bound_of P) s"
    by(simp add:maximalD determ_maximalD)
  also have "... = wp a (\<lambda>s. ?Pc s + P s) s"
    by(simp)
  also from da sP sPc have "... = wp a ?Pc s + wp a P s"
    by(subst additiveD[OF determ_additiveD], simp_all add:sP sPc)
  also from sPc dr have "... \<le> wp b ?Pc s + wp a P s"
    by(auto)
  also from less have "... < wp b ?Pc s + wp b P s"
    by(auto)
  also from sab sP sPc have "... \<le> wp b (\<lambda>s. ?Pc s + P s) s"
    by(blast)
  finally have "\<not>wp b (\<lambda>s. bound_of P) s \<le> bound_of P"
    by(simp)
  thus "\<not>bounded_by (bound_of P) (wp b (\<lambda>s. bound_of P))"
    by(auto)
next
  txt {* However, *}
  fix P::"'s \<Rightarrow> real" assume sP: "sound P"
  hence "nneg (\<lambda>s. bound_of P)" by(auto)
  moreover have "bounded_by (bound_of P) (\<lambda>s. bound_of P)" by(auto)
  ultimately
  show "bounded_by (bound_of P) (wp b (\<lambda>s. bound_of P))"
    using wb by(auto dest!:well_def_wp_healthy)
qed

subsection {* The Algebraic Structure of Refinement *}

text {* Well-defined programs form a half-bounded semilattice under refinement, where @{term Abort}
is bottom, and @{term "a \<Sqinter> b"} is @{term inf}. There is no unique top element, but all
fully-deterministic programs are maximal.

The type that we construct here is not especially useful, but serves as a convenient way to express
this result. *}

quotient_type 's program =
  "'s prog" / partial : "\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b"
proof(rule part_equivpI)
  have "Skip \<simeq> Skip" and "well_def Skip" by(auto intro:wd_intros)
  thus "\<exists>x. x \<simeq> x \<and> well_def x \<and> well_def x" by(blast)
  show "symp (\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b)"
  proof(rule sympI, safe)
    fix a::"'a prog" and b
    assume "a \<simeq> b"
    hence "equiv_trans (wp a) (wp b)"
      by(simp add:pequiv_equiv_trans)
    thus "b \<simeq> a" by(simp add:ac_simps pequiv_equiv_trans)
  qed
  show "transp (\<lambda>a b. a \<simeq> b \<and> well_def a \<and> well_def b)"
    by(rule transpI, safe, rule pequiv_trans)
qed

instantiation program :: (type) semilattice_inf begin
lift_definition
  less_eq_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> bool" is refines
proof(safe)
  fix a::"'a prog" and b c d
  assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
  also assume "a \<sqsubseteq> c"
  also assume "c \<simeq> d"
  finally show "b \<sqsubseteq> d" .
next
  fix a::"'a prog" and b c d
  assume "a \<simeq> b"
  also assume "b \<sqsubseteq> d"
  also assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
  finally show "a \<sqsubseteq> c" .
qed (* XXX - what's up here? *)

lift_definition
  less_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> bool"
  is "\<lambda>a b. a \<sqsubseteq> b \<and> \<not> b \<sqsubseteq> a"
proof(safe)
  fix a::"'a prog" and b c d
  assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
  also assume "a \<sqsubseteq> c"
  also assume "c \<simeq> d"
  finally show "b \<sqsubseteq> d" .
next
  fix a::"'a prog" and b c d
  assume "a \<simeq> b"
  also assume "b \<sqsubseteq> d"
  also assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
  finally show "a \<sqsubseteq> c" .
next
  fix a b and c::"'a prog" and d
  assume "c \<simeq> d"
  also assume "d \<sqsubseteq> b"
  also assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
  finally have "c \<sqsubseteq> a" .
  moreover assume "\<not> c \<sqsubseteq> a"
  ultimately show False by(auto)
next
  fix a b and c::"'a prog" and d
  assume "c \<simeq> d" hence "d \<simeq> c" by(simp add:ac_simps)
  also assume "c \<sqsubseteq> a"
  also assume "a \<simeq> b"
  finally have "d \<sqsubseteq> b" .
  moreover assume "\<not> d \<sqsubseteq> b"
  ultimately show False by(auto)
qed

lift_definition
  inf_program :: "'a program \<Rightarrow> 'a program \<Rightarrow> 'a program" is DC
proof(safe)
  fix a b c d::"'s prog"
  assume "a \<simeq> b" and "c \<simeq> d"
  thus "(a \<Sqinter> c) \<simeq> (b \<Sqinter> d)" by(rule pequiv_DC)
next
  fix a c::"'s prog"
  assume "well_def a" "well_def c"
  thus "well_def (a \<Sqinter> c)" by(rule wd_intros)
next
  fix a c::"'s prog"
  assume "well_def a" "well_def c"
  thus "well_def (a \<Sqinter> c)" by(rule wd_intros)
qed

instance
proof
  fix x y::"'a program"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by(transfer, simp)
  show "x \<le> x"
    by(transfer, auto)
  show "inf x y \<le> x"
    by(transfer, rule left_refines_DC)
  show "inf x y \<le> y"
    by(transfer, rule right_refines_DC)
  assume "x \<le> y" and "y \<le> x" thus "x = y"
    by(transfer, iprover intro:pequiv_antisym)
next
  fix x y z::"'a program"
  assume "x \<le> y" and "y \<le> z"
  thus "x \<le> z"
    by(transfer, iprover intro:pr_trans)
next
  fix x y z::"'a program"
  assume "x \<le> y" and "x \<le> z"
  thus "x \<le> inf y z"
    by(transfer, iprover intro:DC_refines)
qed
end

instantiation program :: (type) bot begin
lift_definition
  bot_program :: "'a program" is Abort
  by(auto intro:wd_intros)

instance ..
end

lemma eq_det: "\<And>a b::'s prog. \<lbrakk> a \<simeq> b; determ (wp a) \<rbrakk> \<Longrightarrow> determ (wp b)"
proof(intro determI additiveI maximalI)
  fix a b::"'s prog" and P::"'s \<Rightarrow> real"
    and Q::"'s \<Rightarrow> real" and s::"'s"
  assume da: "determ (wp a)"
  assume sP: "sound P" and sQ: "sound Q"
    and eq: "a \<simeq> b"
  hence "wp b (\<lambda>s. P s + Q s) s =
         wp a (\<lambda>s. P s + Q s) s"
    by(simp add:sound_intros)
  also from da sP sQ
  have "... = wp a P s + wp a Q s"
    by(simp add:additiveD determ_additiveD)
  also from eq sP sQ
  have "... = wp b P s + wp b Q s"
    by(simp add:pequivD)
  finally show "wp b (\<lambda>s. P s + Q s) s = wp b P s + wp b Q s" .
next
  fix a b::"'s prog" and c::real
  assume da: "determ (wp a)"
  assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
  moreover assume nn: "0 \<le> c"
  ultimately have "wp b (\<lambda>_. c) = wp a (\<lambda>_. c)"
    by(simp add:pequivD const_sound)
  also from da nn have "... = (\<lambda>_. c)"
    by(simp add:determ_maximalD maximalD)
  finally show "wp b (\<lambda>_. c) = (\<lambda>_. c)" .
qed

lift_definition
  pdeterm :: "'s program \<Rightarrow> bool"
  is "\<lambda>a. determ (wp a)"
proof(safe)
  fix a b::"'s prog"
  assume "a \<simeq> b" and "determ (wp a)"
  thus "determ (wp b)" by(rule eq_det)
next
  fix a b::"'s prog"
  assume "a \<simeq> b" hence "b \<simeq> a" by(simp add:ac_simps)
  moreover assume "determ (wp b)"
  ultimately show "determ (wp a)" by(rule eq_det)
qed

lemma determ_maximal:
  "\<lbrakk> pdeterm a; a \<le> x \<rbrakk> \<Longrightarrow> a = x"
  by(transfer, auto intro:refines_determ)

subsection {* Data Refinement *}

text {* A projective data refinement construction for pGCL. By projective, we mean that the abstract
state is always a function (@{term \<phi>}) of the concrete state. Refinement may be predicated (@{term
G}) on the state. *}

definition
  drefines :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a prog \<Rightarrow> 'b prog \<Rightarrow> bool"
where
  "drefines \<phi> G A B \<equiv> \<forall>P Q. (unitary P \<and> unitary Q \<and> (P \<tturnstile> wp A Q)) \<longrightarrow>
                            (\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>))"

lemma drefinesD[dest]:
  "\<lbrakk> drefines \<phi> G A B; unitary P; unitary Q; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow>
   \<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
  unfolding drefines_def by(blast)

text {* We can alternatively use G as an assumption: *}
lemma drefinesD2:
  assumes dr:  "drefines \<phi> G A B"
      and uP:  "unitary P"
      and uQ:  "unitary Q"
      and wpA: "P \<tturnstile> wp A Q"
      and G:   "G s"
  shows "(P o \<phi>) s \<le> wp B (Q o \<phi>) s"
proof -
  from uP have "0 \<le> (P o \<phi>) s" unfolding o_def by(blast)
  with G have "(P o \<phi>) s = (\<guillemotleft>G\<guillemotright> && (P o \<phi>)) s"
    by(simp add:exp_conj_def)
  also from assms have "... \<le> wp B (Q o \<phi>) s" by(blast)
  finally show "(P o \<phi>) s \<le> ..." .
qed

text {* This additional form is sometimes useful: *}
lemma drefinesD3:
  assumes dr: "drefines \<phi> G a b"
      and G:  "G s"
      and uQ: "unitary Q"
      and wa: "well_def a"
  shows "wp a Q (\<phi> s) \<le> wp b (Q o \<phi>) s"
proof -
  let "?L s'" = "wp a Q s'"
  from uQ wa have sL: "sound ?L" by(blast)
  from uQ wa have bL: "bounded_by 1 ?L" by(blast)

  have "?L \<tturnstile> ?L" by(simp)
  with sL and bL and assms
  show ?thesis
    by(blast intro:drefinesD2[OF dr, where P="?L", simplified])
qed

lemma drefinesI[intro]:
  "\<lbrakk> \<And>P Q. \<lbrakk> unitary P; unitary Q; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow>
           \<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>) \<rbrakk> \<Longrightarrow>
   drefines \<phi> G A B"
  unfolding drefines_def by(blast)

text {* Use G as an assumption, when showing refinement: *}
lemma drefinesI2:
  fixes   A::"'a prog"
    and   B::"'b prog"
    and   \<phi>::"'b \<Rightarrow> 'a"
    and   G::"'b \<Rightarrow> bool"
  assumes wB: "well_def B"
      and withAs:
        "\<And>P Q s. \<lbrakk> unitary P; unitary Q;
                 G s; P \<tturnstile> wp A Q \<rbrakk> \<Longrightarrow> (P o \<phi>) s \<le> wp B (Q o \<phi>) s"
  shows "drefines \<phi> G A B"
proof
  fix P and Q
  assume uP:  "unitary P"
     and uQ:  "unitary Q"
     and wpA: "P \<tturnstile> wp A Q"

  hence "\<And>s. G s \<Longrightarrow> (P o \<phi>) s \<le> wp B (Q o \<phi>) s"
    using withAs by(blast)
  moreover
  from uQ have "unitary (Q o \<phi>)"
    unfolding o_def by(blast)
  moreover
  from uP have "unitary (P o \<phi>)"
    unfolding o_def by(blast)
  ultimately
  show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
    using wB by(blast intro:entails_pconj_assumption)
qed

lemma dr_strengthen_guard:
  fixes a::"'s prog" and b::"'t prog"
  assumes fg: "\<And>s. F s \<Longrightarrow> G s"
      and drab: "drefines \<phi> G a b"
  shows "drefines \<phi> F a b"
proof(intro drefinesI)
  fix P Q::"'s expect"
  assume uP: "unitary P" and uQ: "unitary Q"
     and wp: "P \<tturnstile> wp a Q"
  from fg have "\<And>s. \<guillemotleft>F\<guillemotright> s \<le> \<guillemotleft>G\<guillemotright> s" by(simp add:embed_bool_def)
  hence "(\<guillemotleft>F\<guillemotright> && (P o \<phi>)) \<tturnstile> (\<guillemotleft>G\<guillemotright> && (P o \<phi>))" by(auto intro:pconj_mono le_funI simp:exp_conj_def)
  also from drab uP uQ wp have "... \<tturnstile> wp b (Q o \<phi>)" by(auto)
  finally show "\<guillemotleft>F\<guillemotright> && (P o \<phi>) \<tturnstile> wp b (Q o \<phi>)" .
qed

text {* Probabilistic correspondence, @{term pcorres}, is equality on distribution transformers,
modulo a guard. It is the analogue, for data refinement, of program equivalence for program
refinement. *}
definition
  pcorres :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a prog \<Rightarrow> 'b prog \<Rightarrow> bool"
where
  "pcorres \<phi> G A B \<longleftrightarrow>
   (\<forall>Q. unitary Q \<longrightarrow>  \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>))"

lemma pcorresI:
  "\<lbrakk> \<And>Q. unitary Q \<Longrightarrow> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>) \<rbrakk> \<Longrightarrow>
   pcorres \<phi> G A B"
  by(simp add:pcorres_def)

text {* Often easier to use, as it allows one to assume the precondition. *}
lemma pcorresI2[intro]:
  fixes A::"'a prog" and B::"'b prog"
  assumes withG: "\<And>Q s. \<lbrakk> unitary Q; G s \<rbrakk> \<Longrightarrow> wp A Q (\<phi> s)= wp B (Q o \<phi>) s"
      and wA: "well_def A"
      and wB: "well_def B"
  shows "pcorres \<phi> G A B"
proof(rule pcorresI, rule ext)
  fix Q::"'a \<Rightarrow> real" and s::'b
  assume uQ: "unitary Q"
  hence uQ\<phi>: "unitary (Q o \<phi>)" by(auto)
  show "(\<guillemotleft>G\<guillemotright> && (wp A Q \<circ> \<phi>)) s = (\<guillemotleft>G\<guillemotright> && wp B (Q \<circ> \<phi>)) s"
  proof(cases "G s")
    case True note this
    moreover
    from well_def_wp_healthy[OF wA] uQ have "0 \<le> wp A Q (\<phi> s)" by(blast)
    moreover
    from well_def_wp_healthy[OF wB] uQ\<phi> have "0 \<le> wp B (Q o \<phi>) s" by(blast)
    ultimately show ?thesis
      using uQ by(simp add:exp_conj_def withG)
  next
    case False note this
    moreover
    from well_def_wp_healthy[OF wA] uQ have "wp A Q (\<phi> s) \<le> 1" by(blast)
    moreover
    from well_def_wp_healthy[OF wB] uQ\<phi> have "wp B (Q o \<phi>) s \<le> 1"
      by(blast dest!:healthy_bounded_byD intro:sound_nneg)
    ultimately show ?thesis by(simp add:exp_conj_def)
  qed
qed

lemma pcorresD:
  "\<lbrakk> pcorres \<phi> G A B; unitary Q \<rbrakk> \<Longrightarrow> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>)"
  unfolding pcorres_def by(simp)

text {* Again, easier to use if the precondition is known to hold. *}
lemma pcorresD2:
  assumes pc: "pcorres \<phi> G A B"
      and uQ: "unitary Q"
      and wA: "well_def A" and wB: "well_def B"
      and G: "G s"
  shows "wp A Q (\<phi> s) = wp B (Q o \<phi>) s"
proof -
  from uQ well_def_wp_healthy[OF wA] have "0 \<le> wp A Q (\<phi> s)" by(auto)
  with G have "wp A Q (\<phi> s) = \<guillemotleft>G\<guillemotright> s .& wp A Q (\<phi> s)" by(simp)
  also {
    from pc uQ have "\<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (Q o \<phi>)"
      by(rule pcorresD)
    hence "\<guillemotleft>G\<guillemotright> s .& wp A Q (\<phi> s) = \<guillemotleft>G\<guillemotright> s .& wp B (Q o \<phi>) s"
      unfolding exp_conj_def o_def by(rule fun_cong)
  }
  also {
    from uQ have "sound Q" by(auto)
    hence "sound (Q o \<phi>)" by(auto intro:sound_intros)
    with well_def_wp_healthy[OF wB] have "0 \<le> wp B (Q o \<phi>) s" by(auto)
    with G have "\<guillemotleft>G\<guillemotright> s .& wp B (Q o \<phi>) s = wp B (Q o \<phi>) s" by(simp)
  }
  finally show ?thesis .
qed

subsection {* The Algebra of Data Refinement *}

text {* Program refinement implies a trivial data refinement: *}
lemma refines_drefines:
  fixes a::"'s prog"
  assumes rab: "a \<sqsubseteq> b" and wb: "well_def b"
  shows "drefines (\<lambda>s. s) G a b"
proof(intro drefinesI2 wb, simp add:o_def)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume sQ: "unitary Q"
  assume "P \<tturnstile> wp a Q" hence "P s \<le> wp a Q s" by(auto)
  also from rab sQ have "... \<le> wp b Q s" by(auto)
  finally show "P s \<le> wp b Q s" .
qed

text {* Data refinement is transitive: *}
lemma dr_trans[trans]:
  fixes A::"'a prog" and B::"'b prog" and C::"'c prog"
  assumes drAB: "drefines \<phi> G A B"
      and drBC: "drefines \<phi>' G' B C"
      and Gimp: "\<And>s. G' s \<Longrightarrow> G (\<phi>' s)"
  shows "drefines (\<phi> o \<phi>') G' A C"
proof(rule drefinesI)
  fix P::"'a \<Rightarrow> real" and Q::"'a \<Rightarrow> real" and s::'a
  assume uP: "unitary P" and uQ: "unitary Q"
     and wpA: "P \<tturnstile> wp A Q"

  have "\<guillemotleft>G'\<guillemotright> && \<guillemotleft>G o \<phi>'\<guillemotright> = \<guillemotleft>G'\<guillemotright>"
  proof(rule ext, unfold exp_conj_def)
    fix x
    show "\<guillemotleft>G'\<guillemotright> x .& \<guillemotleft>G o \<phi>'\<guillemotright> x = \<guillemotleft>G'\<guillemotright> x" (is ?X)
    proof(cases "G' x")
      case False then show ?X by(simp)
    next
      case True
      moreover
      with Gimp have "(G o \<phi>') x" by(simp add:o_def)
      ultimately
      show ?X by(simp)
    qed
  qed

  with uP
  have "\<guillemotleft>G'\<guillemotright> && (P o (\<phi> o \<phi>')) = \<guillemotleft>G'\<guillemotright> && ((\<guillemotleft>G\<guillemotright> && (P o \<phi>)) o \<phi>')"
    by(simp add:exp_conj_assoc o_assoc)

  also {
    from uP uQ wpA and drAB
    have "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)"
      by(blast intro:drefinesD)

    with drBC and uP uQ
    have "\<guillemotleft>G'\<guillemotright> && ((\<guillemotleft>G\<guillemotright> && (P o \<phi>)) o \<phi>') \<tturnstile> wp C ((Q o \<phi>) o \<phi>')"
      by(blast intro:unitary_intros drefinesD)
  }

  finally
  show "\<guillemotleft>G'\<guillemotright> && (P o (\<phi> o \<phi>')) \<tturnstile> wp C (Q o (\<phi> o \<phi>'))"
    by(simp add:o_assoc)
qed

text {* Data refinement composes with program refinement: *}
lemma pr_dr_trans[trans]:
  assumes prAB: "A \<sqsubseteq> B"
      and drBC: "drefines \<phi> G B C"
  shows "drefines \<phi> G A C"
proof(rule drefinesI)
  fix P and Q
  assume uP:  "unitary P"
     and uQ:  "unitary Q"
     and wpA: "P \<tturnstile> wp A Q"

  note wpA
  also from uQ and prAB have "wp A Q \<tturnstile> wp B Q" by(blast)
  finally have "P \<tturnstile> wp B Q" .
  with uP uQ drBC
  show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp C (Q o \<phi>)" by(blast intro:drefinesD)
qed

lemma dr_pr_trans[trans]:
  assumes drAB: "drefines \<phi> G A B"
  assumes prBC: "B \<sqsubseteq> C"
  shows "drefines \<phi> G A C"
proof(rule drefinesI)
  fix P and Q
  assume uP:  "unitary P"
     and uQ:  "unitary Q"
     and wpA: "P \<tturnstile> wp A Q"

  with drAB have "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp B (Q o \<phi>)" by(blast intro:drefinesD)
  also from uQ prBC have "... \<tturnstile> wp C (Q o \<phi>)" by(blast)
  finally show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> ..." .
qed

text {* If the projection @{term \<phi>} commutes with the transformer, then data refinement is
reflexive: *}
lemma dr_refl:
  assumes wa: "well_def a"
      and comm: "\<And>Q. unitary Q \<Longrightarrow> wp a Q o \<phi> \<tturnstile> wp a (Q o \<phi>)"
  shows "drefines \<phi> G a a"
proof(intro drefinesI2 wa)
  fix P and Q and s
  assume wp: "P \<tturnstile> wp a Q"
  assume uQ: "unitary Q"

  have "(P o \<phi>) s = P (\<phi> s)" by(simp)
  also from wp have "... \<le> wp a Q (\<phi> s)" by(blast)
  also {
    from comm uQ have "wp a Q o \<phi> \<tturnstile> wp a (Q o \<phi>)" by(blast)
    hence "(wp a Q o \<phi>) s \<le> wp a (Q o \<phi>) s" by(blast)
    hence "wp a Q (\<phi> s) \<le> ..." by(simp)
  }
  finally show  "(P o \<phi>) s \<le> wp a (Q o \<phi>) s" .
qed

text {* Correspondence implies data refinement *}
lemma pcorres_drefine:
  assumes corres: "pcorres \<phi> G A C"
      and wC: "well_def C"
  shows "drefines \<phi> G A C"
proof
  fix P and Q
  assume uP: "unitary P" and uQ: "unitary Q"
     and wpA: "P \<tturnstile> wp A Q"
  from wpA have "P o \<phi> \<tturnstile> wp A Q o \<phi>" by(simp add:o_def le_fun_def)
  hence "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> \<guillemotleft>G\<guillemotright> && (wp A Q o \<phi>)"
    by(rule exp_conj_mono_right)
  also from corres uQ
  have "... = \<guillemotleft>G\<guillemotright> && (wp C (Q o \<phi>))" by(rule pcorresD)
  also
  have "... \<tturnstile> wp C (Q o \<phi>)"
  proof(rule le_funI)
    fix s
    from uQ have "unitary (Q o \<phi>)" by(rule unitary_intros)
    with well_def_wp_healthy[OF wC] have nn_wpC: "0 \<le> wp C (Q o \<phi>) s" by(blast)
    show "(\<guillemotleft>G\<guillemotright> && wp C (Q o \<phi>)) s \<le> wp C (Q o \<phi>) s"
    proof(cases "G s")
      case True
      with nn_wpC show ?thesis by(simp add:exp_conj_def)
    next
      case False note this
      moreover {
        from uQ have "unitary (Q o \<phi>)" by(simp)
        with well_def_wp_healthy[OF wC] have "wp C (Q o \<phi>) s \<le> 1" by(auto)
      }
      moreover note nn_wpC
      ultimately show ?thesis by(simp add:exp_conj_def)
    qed
  qed
  finally show "\<guillemotleft>G\<guillemotright> && (P o \<phi>) \<tturnstile> wp C (Q o \<phi>)" .
qed

text {* Any \emph{data} refinement of a deterministic program is correspondence. This is the
analogous result to that relating program refinement and equivalence. *}
lemma drefines_determ:
  fixes a::"'a prog" and b::"'b prog"
  assumes da: "determ (wp a)"
      and wa: "well_def a"
      and wb: "well_def b"
      and dr: "drefines \<phi> G a b"
  shows "pcorres \<phi> G a b"
  txt {* The proof follows exactly the same form
    as that for program refinement: Assuming that correspondence
    \emph{doesn't} hold, we show that @{term "wp b"} is not feasible,
    and thus not healthy, contradicting the assumption. *}
proof(rule pcorresI, rule contrapos_pp)
  from wb show "feasible (wp b)" by(auto)

  note ha = well_def_wp_healthy[OF wa]
  note hb = well_def_wp_healthy[OF wb]

  from wb have "sublinear (wp b)" by(auto)
  moreover from hb have "feasible (wp b)" by(auto)
  ultimately have sab: "sub_add (wp b)" by(rule sublinear_subadd)

  fix Q::"'a \<Rightarrow> real"
  assume uQ: "unitary Q"
  hence uQ\<phi>: "unitary (Q o \<phi>)" by(auto)
  assume ne: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<noteq> \<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"
  hence ne': "wp a Q o \<phi> \<noteq> wp b (Q o \<phi>)" by(auto)

  txt {* From refinement, @{term "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)"}
    lies below @{term "\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"}. *}
  from ha uQ
  have gle: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<tturnstile> wp b (Q o \<phi>)" by(blast intro!:drefinesD[OF dr])
  have le: "\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>) \<tturnstile> \<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)"
    unfolding exp_conj_def
  proof(rule le_funI)
    fix s
    from gle have "\<guillemotleft>G\<guillemotright> s .& (wp a Q o \<phi>) s \<le> wp b (Q o \<phi>) s"
      unfolding exp_conj_def by(auto)
    hence "\<guillemotleft>G\<guillemotright> s .& (\<guillemotleft>G\<guillemotright> s .& (wp a Q o \<phi>) s) \<le> \<guillemotleft>G\<guillemotright> s .& wp b (Q o \<phi>) s"
      by(auto intro:pconj_mono)
    moreover from uQ ha have "wp a Q (\<phi> s) \<le> 1"
      by(auto dest:healthy_bounded_byD)
    moreover from uQ ha have "0 \<le> wp a Q (\<phi> s)"
      by(auto)
    ultimately
    show "\<guillemotleft> G \<guillemotright> s .& (wp a Q \<circ> \<phi>) s \<le> \<guillemotleft> G \<guillemotright> s .& wp b (Q \<circ> \<phi>) s"
      by(simp add:pconj_assoc)
  qed

  txt {* If the programs do not correspond, the terms must differ somewhere, and given the previous
  result, the second must be somewhere strictly larger than the first: *}
  have nle: "\<exists>s. (\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)) s"
  proof(rule contrapos_np[OF ne], rule ext, rule antisym)
    fix s
    from le show "(\<guillemotleft>G\<guillemotright> && (wp a Q o \<phi>)) s \<le> (\<guillemotleft>G\<guillemotright> && wp b (Q o \<phi>)) s"
      by(blast)
  next
    fix s
    assume "\<not> (\<exists>s. (\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s)"
    thus " (\<guillemotleft>G\<guillemotright> && (wp b (Q \<circ> \<phi>))) s \<le> (\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s"
      by(simp add:not_less)
  qed
  from this obtain s where less_s:
    "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s < (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
    by(blast)
  txt {* The transformers themselves must differ at this point: *}
  hence larger: "wp a Q (\<phi> s) < wp b (Q \<circ> \<phi>) s"
  proof(cases "G s")
    case True
    moreover from ha uQ have "0 \<le> wp a Q (\<phi> s)"
      by(blast)
    moreover from hb uQ\<phi> have "0 \<le> wp b (Q o \<phi>) s"
      by(blast)
    moreover note less_s
    ultimately show ?thesis by(simp add:exp_conj_def)
  next
    case False
    moreover from ha uQ have "wp a Q (\<phi> s) \<le> 1"
      by(blast)
    moreover {
      from uQ have "bounded_by 1 (Q o \<phi>)"
        by(blast)
      moreover from unitary_sound[OF uQ]
      have "sound (Q o \<phi>)" by(auto)
      ultimately have "wp b (Q o \<phi>) s \<le> 1"
        using hb by(auto)
    }
    moreover note less_s
    ultimately show ?thesis by(simp add:exp_conj_def)
  qed
  from less_s have "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s \<noteq> (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
    by(force)
  txt {* @{term G} must also hold, as otherwise both would be zero. *}
  hence G_s: "G s"
  proof(rule contrapos_np)
    assume nG: "\<not> G s"
    moreover from ha uQ have "wp a Q (\<phi> s) \<le> 1"
      by(blast)
    moreover {
      from uQ have "bounded_by 1 (Q o \<phi>)"
        by(blast)
      moreover from unitary_sound[OF uQ]
      have "sound (Q o \<phi>)" by(auto)
      ultimately have "wp b (Q o \<phi>) s \<le> 1"
        using hb by(auto)
    }
    ultimately
    show "(\<guillemotleft>G\<guillemotright> && (wp a Q \<circ> \<phi>)) s = (\<guillemotleft>G\<guillemotright> && wp b (Q \<circ> \<phi>)) s"
      by(simp add:exp_conj_def)
  qed

  txt {* Take a carefully constructed expectation: *}
  let ?Qc = "\<lambda>s. bound_of Q - Q s"
  have bQc: "bounded_by 1 ?Qc"
  proof(rule bounded_byI)
    fix s
    from uQ have "bound_of Q \<le> 1" and "0 \<le> Q s" by(auto)
    thus "bound_of Q - Q s \<le> 1" by(auto)
  qed
  have sQc: "sound ?Qc"
  proof(rule soundI)
    from bQc show "bounded ?Qc" by(auto)

    show "nneg ?Qc"
    proof(rule nnegI)
      fix s
      from uQ have "Q s \<le> bound_of Q" by(auto)
      thus "0 \<le> bound_of Q - Q s" by(auto)
    qed
  qed

  txt {* By the maximality of @{term "wp a"}, @{term "wp b"} must violate feasibility, by mapping
  @{term s} to something strictly greater than @{term "bound_of Q"}. *}
  from uQ have "0 \<le> bound_of Q" by(auto)
  with da have "bound_of Q = wp a (\<lambda>s. bound_of Q) (\<phi> s)"
    by(simp add:maximalD determ_maximalD)
  also have "wp a (\<lambda>s. bound_of Q) (\<phi> s) = wp a (\<lambda>s. Q s + ?Qc s) (\<phi> s)"
    by(simp)
  also {
    from da have "additive (wp a)" by(blast)
    with uQ sQc
    have "wp a (\<lambda>s. Q s + ?Qc s) (\<phi> s) =
          wp a Q (\<phi> s) + wp a ?Qc (\<phi> s)" by(subst additiveD, blast+)
  }
  also {
    from ha and sQc and bQc
    have "\<guillemotleft>G\<guillemotright> && (wp a ?Qc o \<phi>) \<tturnstile> wp b (?Qc o \<phi>)"
      by(blast intro!:drefinesD[OF dr])
    hence "(\<guillemotleft>G\<guillemotright> && (wp a ?Qc o \<phi>)) s \<le> wp b (?Qc o \<phi>) s"
      by(blast)
    moreover from sQc and ha
    have "0 \<le> wp a (\<lambda>s. bound_of Q - Q s) (\<phi> s)"
      by(blast)
    ultimately
    have "wp a ?Qc (\<phi> s) \<le> wp b (?Qc o \<phi>) s"
      using G_s by(simp add:exp_conj_def)
    hence "wp a Q (\<phi> s) + wp a ?Qc (\<phi> s) \<le> wp a Q (\<phi> s) + wp b (?Qc o \<phi>) s"
      by(rule add_left_mono)
    also with larger
    have "wp a Q (\<phi> s) + wp b (?Qc o \<phi>) s <
          wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s"
      by(auto)
    finally
    have "wp a Q (\<phi> s) + wp a ?Qc (\<phi> s) <
          wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s" .
  }
  also from sab and unitary_sound[OF uQ] and sQc
  have "wp b (Q o \<phi>) s + wp b (?Qc o \<phi>) s \<le>
        wp b (\<lambda>s. (Q o \<phi>) s + (?Qc o \<phi>) s) s"
    by(blast)
  also have "... = wp b (\<lambda>s. bound_of Q) s"
    by(simp)
  finally
  show "\<not> feasible (wp b)"
  proof(rule contrapos_pn)
    assume fb: "feasible (wp b)"
    have "bounded_by (bound_of Q) (\<lambda>s. bound_of Q)" by(blast)
    hence "bounded_by (bound_of Q) (wp b (\<lambda>s. bound_of Q))"
      using uQ by(blast intro:feasible_boundedD[OF fb])
    hence "wp b (\<lambda>s. bound_of Q) s \<le> bound_of Q" by(blast)
    thus "\<not> bound_of Q < wp b (\<lambda>s. bound_of Q) s" by(simp)
  qed
qed

subsection {* Structural Rules for Correspondence *}

lemma pcorres_Skip:
  "pcorres \<phi> G Skip Skip"
  by(simp add:pcorres_def wp_eval)

text {* Correspondence composes over sequential composition. *}
lemma pcorres_Seq:
  fixes A::"'b prog" and B::"'c prog"
    and C::"'b prog" and D::"'c prog"
    and \<phi>::"'c \<Rightarrow> 'b"
  assumes pcAB: "pcorres \<phi> G A B"
      and pcCD: "pcorres \<phi> H C D"
      and wA: "well_def A" and wB: "well_def B"
      and wC: "well_def C" and wD: "well_def D"
      and p3p2: "\<And>Q. unitary Q \<Longrightarrow> \<guillemotleft>I\<guillemotright> && wp B Q = wp B (\<guillemotleft>H\<guillemotright> && Q)"
      and p1p3: "\<And>s. G s \<Longrightarrow> I s"
  shows "pcorres \<phi> G (A;;C) (B;;D)"
proof(rule pcorresI)
  fix Q::"'b \<Rightarrow> real"
  assume uQ: "unitary Q"
  with well_def_wp_healthy[OF wC] have uCQ: "unitary (wp C Q)" by(auto)
  from uQ well_def_wp_healthy[OF wD] have uDQ: "unitary (wp D (Q o \<phi>))"
    by(auto dest:unitary_comp)

  have p3p1: "\<And>R S. \<lbrakk> unitary R; unitary S; \<guillemotleft>I\<guillemotright> && R = \<guillemotleft>I\<guillemotright> && S \<rbrakk> \<Longrightarrow>
                    \<guillemotleft>G\<guillemotright> && R = \<guillemotleft>G\<guillemotright> && S"
  proof(rule ext)
    fix R::"'c \<Rightarrow> real" and S::"'c \<Rightarrow> real" and s::'c
    assume a3: "\<guillemotleft>I\<guillemotright> && R = \<guillemotleft>I\<guillemotright> && S"
       and uR: "unitary R" and uS: "unitary S"
    show "(\<guillemotleft>G\<guillemotright> && R) s = (\<guillemotleft>G\<guillemotright> && S) s"
    proof(simp add:exp_conj_def, cases "G s")
      case False note this
      moreover from uR have "R s \<le> 1" by(blast)
      moreover from uS have "S s \<le> 1" by(blast)
      ultimately show "\<guillemotleft>G\<guillemotright> s .& R s = \<guillemotleft>G\<guillemotright> s .& S s"
        by(simp)
    next
      case True note p1 = this
      with p1p3 have "I s" by(blast)
      with fun_cong[OF a3, where x=s] have "1 .& R s = 1 .& S s"
        by(simp add:exp_conj_def)
      with p1 show "\<guillemotleft>G\<guillemotright> s .& R s = \<guillemotleft>G\<guillemotright> s .& S s"
        by(simp)
    qed
  qed

  show "\<guillemotleft>G\<guillemotright> && (wp (A;;C) Q o \<phi>) = \<guillemotleft>G\<guillemotright> && wp (B;;D) (Q o \<phi>)"
  proof(simp add:wp_eval)
    from uCQ pcAB have "\<guillemotleft>G\<guillemotright> && (wp A (wp C Q) \<circ> \<phi>) =
                        \<guillemotleft>G\<guillemotright> && wp B ((wp C Q) \<circ> \<phi>)"
      by(auto dest:pcorresD)
    also have "\<guillemotleft>G\<guillemotright> && wp B ((wp C Q) \<circ> \<phi>) =
               \<guillemotleft>G\<guillemotright> && wp B (wp D (Q \<circ> \<phi>))"
    proof(rule p3p1)
      from uCQ well_def_wp_healthy[OF wB] show "unitary (wp B (wp C Q \<circ> \<phi>))"
        by(auto intro:unitary_comp)
      from uDQ well_def_wp_healthy[OF wB] show "unitary (wp B (wp D (Q \<circ> \<phi>)))"
        by(auto)

      from uQ have "\<guillemotleft> H \<guillemotright> && (wp C Q \<circ> \<phi>) = \<guillemotleft> H \<guillemotright> && wp D (Q \<circ> \<phi>)"
        by(blast intro:pcorresD[OF pcCD])
      thus "\<guillemotleft> I \<guillemotright> && wp B (wp C Q \<circ> \<phi>) = \<guillemotleft> I \<guillemotright> && wp B (wp D (Q \<circ> \<phi>))"
        by(simp add:p3p2 uCQ uDQ)
    qed
    finally show "\<guillemotleft>G\<guillemotright> && (wp A (wp C Q) \<circ> \<phi>) = \<guillemotleft>G\<guillemotright> && wp B (wp D (Q \<circ> \<phi>))" .
  qed
qed

subsection {* Structural Rules for Data Refinement *}

lemma dr_Skip:
  fixes \<phi>::"'c \<Rightarrow> 'b"
  shows "drefines \<phi> G Skip Skip"
proof(intro drefinesI2 wd_intros)
  fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c
  assume "P \<tturnstile> wp Skip Q"
  hence "(P o \<phi>) s \<le> wp Skip Q (\<phi> s)" by(simp, blast)
  thus "(P o \<phi>) s \<le> wp Skip (Q o \<phi>) s" by(simp add:wp_eval)
qed

lemma dr_Abort:
  fixes \<phi>::"'c \<Rightarrow> 'b"
  shows "drefines \<phi> G Abort Abort"
proof(intro drefinesI2 wd_intros)
  fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c
  assume "P \<tturnstile> wp Abort Q"
  hence "(P o \<phi>) s \<le> wp Abort Q (\<phi> s)" by(auto)
  thus "(P o \<phi>) s \<le> wp Abort (Q o \<phi>) s" by(simp add:wp_eval)
qed

lemma dr_Apply:
  fixes \<phi>::"'c \<Rightarrow> 'b"
  assumes commutes: "f o \<phi> = \<phi> o g"
  shows "drefines \<phi> G (Apply f) (Apply g)"
proof(intro drefinesI2 wd_intros)
  fix P::"'b \<Rightarrow> real" and Q::"'b \<Rightarrow> real" and s::'c

  assume wp: "P \<tturnstile> wp (Apply f) Q"
  hence "P \<tturnstile> (Q o f)" by(simp add:wp_eval)
  hence "P (\<phi> s) \<le> (Q o f) (\<phi> s)" by(blast)
  also have "... = Q ((f o \<phi>) s)" by(simp)
  also with commutes
  have "... = ((Q o \<phi>) o g) s" by(simp)
  also have "... = wp (Apply g) (Q o \<phi>) s"
    by(simp add:wp_eval)
  finally show "(P o \<phi>) s \<le> wp (Apply g) (Q o \<phi>) s" by(simp)
qed

lemma dr_Seq:
  assumes drAB: "drefines \<phi> P A B"
      and drBC: "drefines \<phi> Q C D"
      and wpB:  "\<guillemotleft>P\<guillemotright> \<tturnstile> wp B \<guillemotleft>Q\<guillemotright>"
      and wB:   "well_def B"
      and wC:   "well_def C"
      and wD:   "well_def D"
  shows "drefines \<phi> P (A;;C) (B;;D)"
proof
  fix R and S
  assume uR: "unitary R" and uS: "unitary S"
     and wpAC: "R \<tturnstile> wp (A;;C) S"

  from uR
  have "\<guillemotleft>P\<guillemotright> && (R o \<phi>) = \<guillemotleft>P\<guillemotright> && (\<guillemotleft>P\<guillemotright> && (R o \<phi>))"
    by(simp add:exp_conj_assoc)

  also {
    from well_def_wp_healthy[OF wC] uR uS
     and wpAC[unfolded eval_wp_Seq o_def]
    have "\<guillemotleft>P\<guillemotright> && (R o \<phi>) \<tturnstile> wp B (wp C S o \<phi>)"
      by(auto intro:drefinesD[OF drAB])
    with wpB well_def_wp_healthy[OF wC] uS
         sublinear_sub_conj[OF well_def_wp_sublinear, OF wB]
    have "\<guillemotleft>P\<guillemotright> && (\<guillemotleft>P\<guillemotright> && (R o \<phi>)) \<tturnstile> wp B (\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>))"
      by(auto intro!:entails_combine dest!:unitary_sound)
  }

  also {
    from uS well_def_wp_healthy[OF wC]
    have "\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>) \<tturnstile> wp D (S o \<phi>)"
      by(auto intro!:drefinesD[OF drBC])
    with well_def_wp_healthy[OF wB] well_def_wp_healthy[OF wC]
         well_def_wp_healthy[OF wD] and unitary_sound[OF uS]
    have "wp B (\<guillemotleft>Q\<guillemotright> && (wp C S o \<phi>)) \<tturnstile> wp B (wp D (S o \<phi>))"
      by(blast intro!:mono_transD)
  }

  finally
  show "\<guillemotleft>P\<guillemotright> && (R o \<phi>) \<tturnstile> wp (B;;D) (S o \<phi>)"
    unfolding wp_eval o_def .
qed

lemma dr_repeat:
  fixes \<phi> :: "'a \<Rightarrow> 'b"
  assumes dr_ab: "drefines \<phi> G a b"
      and Gpr:  "\<guillemotleft>G\<guillemotright> \<tturnstile> wp b \<guillemotleft>G\<guillemotright>"
      and wa:    "well_def a"
      and wb:    "well_def b"
  shows "drefines \<phi> G (repeat n a) (repeat n b)" (is "?X n")
proof(induct n)
  show "?X 0" by(simp add:dr_Skip)

  fix n
  assume IH: "?X n"
  thus "?X (Suc n)" by(auto intro!:dr_Seq Gpr assms wd_intros)
qed

end


theory Bakery
  imports
    Main

begin

record order =
  amount :: nat

find_theorems Record

type_synonym orders = "order set"

fun place_order :: "orders \<Rightarrow> order \<Rightarrow> orders" where
"place_order os order = insert order os"

fun server :: "orders \<Rightarrow> order \<Rightarrow> orders" where
"server os order = place_order os order"

fun place_order_client_server :: "orders \<Rightarrow> order \<Rightarrow> orders" where
"place_order_client_server os order = server os order"

theorem "place_order_client_server os order = place_order os order"
  by simp

type_synonym http_data = string

(* Buggy implementation - requires nat be < 256
fun serialize :: "order \<Rightarrow> http_data" where
"serialize ord = [char_of (amount ord)]"
*)

(* Buggy impl - can only convert one char < 256
fun deserialize :: "http_data \<Rightarrow> order" where
"deserialize d = (
  let amt = of_char (hd d) in
  \<lparr> amount = amt \<rparr>
)"
*)

fun digit_list :: "nat \<Rightarrow> nat list" where
"digit_list 0 = []" |
"digit_list n = n mod 10 # digit_list (n div 10)"

definition string_of_nat :: "nat \<Rightarrow> string" where
"string_of_nat n = map char_of (digit_list n)"

fun nat_of_string :: "string \<Rightarrow> nat" where
"nat_of_string [] = 0" |
"nat_of_string (d # ds) = (of_char d) + 10 * (nat_of_string ds)"

lemma ser_deser[simp]: "nat_of_string (string_of_nat n) = n"
  apply(induction n rule: digit_list.induct)
   apply(auto simp: string_of_nat_def)
  done

definition deserialize :: "http_data \<Rightarrow> order" where
"deserialize d = \<lparr> amount = (nat_of_string d) \<rparr>"

definition serialize :: "order \<Rightarrow> http_data" where
"serialize ord = string_of_nat (amount ord)"

definition http_server :: "http_data \<Rightarrow> orders \<Rightarrow> orders" where
"http_server d os = place_order os (deserialize d)"

definition place_order_http :: "orders \<Rightarrow> order \<Rightarrow> orders" where
"place_order_http os order = http_server (serialize order) os"

theorem "deserialize (serialize order) = order"
  apply(cases order)
  apply(simp add: serialize_def deserialize_def)
  done

theorem "place_order_http os order = place_order os order"
  apply(cases order)
  apply(simp add: serialize_def deserialize_def http_server_def place_order_http_def)
  done

end


(*  Title:      ZF/ex/CoUnit.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Trivial codatatype definitions, one of which goes wrong!\<close>

theory CoUnit imports ZF begin

text \<open>
  See discussion in: L C Paulson.  A Concrete Final Coalgebra Theorem
  for ZF Set Theory.  Report 334, Cambridge University Computer
  Laboratory.  1994.

  \bigskip

  This degenerate definition does not work well because the one
  constructor's definition is trivial!  The same thing occurs with
  Aczel's Special Final Coalgebra Theorem.
\<close>

consts
  counit :: i
codatatype
  "counit" = Con ("x \<in> counit")

inductive_cases ConE: "Con(x) \<in> counit"
  \<comment> \<open>USELESS because folding on \<^term>\<open>Con(xa) \<equiv> xa\<close> fails.\<close>

lemma Con_iff: "Con(x) = Con(y) \<longleftrightarrow> x = y"
  \<comment> \<open>Proving freeness results.\<close>
  by (auto elim!: counit.free_elims)

lemma counit_eq_univ: "counit = quniv(0)"
  \<comment> \<open>Should be a singleton, not everything!\<close>
  apply (rule counit.dom_subset [THEN equalityI])
  apply (rule subsetI)
  apply (erule counit.coinduct)
   apply (rule subset_refl)
    unfolding counit.con_defs
  apply fast
  done

text \<open>
  \medskip A similar example, but the constructor is non-degenerate
  and it works!  The resulting set is a singleton.
\<close>

consts
  counit2 :: i
codatatype
  "counit2" = Con2 ("x \<in> counit2", "y \<in> counit2")

inductive_cases Con2E: "Con2(x, y) \<in> counit2"

lemma Con2_iff: "Con2(x, y) = Con2(x', y') \<longleftrightarrow> x = x' \<and> y = y'"
  \<comment> \<open>Proving freeness results.\<close>
  by (fast elim!: counit2.free_elims)

lemma Con2_bnd_mono: "bnd_mono(univ(0), \<lambda>x. Con2(x, x))"
    unfolding counit2.con_defs
  apply (rule bnd_monoI)
   apply (assumption | rule subset_refl QPair_subset_univ QPair_mono)+
  done

lemma lfp_Con2_in_counit2: "lfp(univ(0), \<lambda>x. Con2(x,x)) \<in> counit2"
  apply (rule singletonI [THEN counit2.coinduct])
  apply (rule qunivI [THEN singleton_subsetI])
  apply (rule subset_trans [OF lfp_subset empty_subsetI [THEN univ_mono]])
  apply (fast intro!: Con2_bnd_mono [THEN lfp_unfold])
  done

lemma counit2_Int_Vset_subset [rule_format]:
  "Ord(i) \<Longrightarrow> \<forall>x y. x \<in> counit2 \<longrightarrow> y \<in> counit2 \<longrightarrow> x \<inter> Vset(i) \<subseteq> y"
  \<comment> \<open>Lemma for proving finality.\<close>
  apply (erule trans_induct)
  apply (tactic "safe_tac (put_claset subset_cs \<^context>)")
  apply (erule counit2.cases)
  apply (erule counit2.cases)
    unfolding counit2.con_defs
  apply (tactic \<open>fast_tac (put_claset subset_cs \<^context>
    addSIs [@{thm QPair_Int_Vset_subset_UN} RS @{thm subset_trans}, @{thm QPair_mono}]
    addSEs [@{thm Ord_in_Ord}, @{thm Pair_inject}]) 1\<close>)
  done

lemma counit2_implies_equal: "\<lbrakk>x \<in> counit2;  y \<in> counit2\<rbrakk> \<Longrightarrow> x = y"
  apply (rule equalityI)
  apply (assumption | rule conjI counit2_Int_Vset_subset [THEN Int_Vset_subset])+
  done

lemma counit2_eq_univ: "counit2 = {lfp(univ(0), \<lambda>x. Con2(x,x))}"
  apply (rule equalityI)
   apply (rule_tac [2] lfp_Con2_in_counit2 [THEN singleton_subsetI])
  apply (rule subsetI)
  apply (drule lfp_Con2_in_counit2 [THEN counit2_implies_equal])
  apply (erule subst)
  apply (rule singletonI)
  done

end


theory Skew_Heap_Analysis
imports "../Skew_Heap/Skew_Heap" Amor
begin

section{* Amortized Analysis of Skew Heaps *}

text{* The following proof is a simplified version of the one by Kaldewaij and
Schoenmakers~\cite{KaldewaijS-IPL91}. *}

fun rheavy :: "'a heap \<Rightarrow> bool" where
"rheavy(Node l _ r) = (size l < size r)"

fun rpath :: "'a heap \<Rightarrow> 'a heap list" where
"rpath Leaf = []" |
"rpath (Node l a r) = Node l a r # rpath r"

fun lpath :: "'a heap \<Rightarrow> 'a heap list" where
"lpath Leaf = []" |
"lpath (Node l a r) = Node l a r # lpath l"

fun G where
"G h = length(filter rheavy (lpath h))"

fun D where
"D h = length(filter (\<lambda>p. \<not> rheavy p) (rpath h))"

lemma Gexp: "2 ^ G h \<le> size h + 1"
by (induction h) auto

corollary Glog: "G h \<le> log 2 (size1 h)"
proof -
  have "G h = log 2 (2 ^ G h)" by (simp add: log_nat_power)
  also have "log 2 (2 ^ G h) \<le> log 2 (size h + 1)"
    by(simp del: G.simps) (metis Gexp Suc_eq_plus1)
  finally show ?thesis by(simp add: size1_def)
qed

lemma Dexp: "2 ^ D h \<le> size h + 1"
by (induction h) auto

corollary Dlog: "D h \<le> log 2 (size1 h)"
proof -
  have "D h = log 2 (2 ^ D h)" by (simp add: log_nat_power)
  also have "log 2 (2 ^ D h) \<le> log 2 (size h + 1)"
    by(simp del: D.simps) (metis Dexp Suc_eq_plus1)
  finally show ?thesis by(simp add: size1_def)
qed

function t\<^sub>m\<^sub>e\<^sub>l\<^sub>d :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d Leaf h = 1" |
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d h Leaf = 1" |
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then t\<^sub>m\<^sub>e\<^sub>l\<^sub>d (Node l2 a2 r2) r1 else t\<^sub>m\<^sub>e\<^sub>l\<^sub>d (Node l1 a1 r1) r2) + 1"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

function t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 Leaf Leaf = 1" |
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 Leaf (Node l2 a2 r2) = t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 r2 Leaf + 1" |
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 (Node l1 a1 r1) Leaf = t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 r1 Leaf + 1" |
"t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 (Node l1 a1 r1) (Node l2 a2 r2) =
  (if a1\<le>a2 then t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 (Node l2 a2 r2) r1 else t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 (Node l1 a1 r1) r2) + 1"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

fun \<Phi> :: "'a heap \<Rightarrow> nat" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + (if size l < size r then 1 else 0)"

corollary amor_eq: "t\<^sub>m\<^sub>e\<^sub>l\<^sub>d2 t1 t2 + \<Phi>(meld2 t1 t2) - \<Phi> t1 - \<Phi> t2 =
  G(meld2 t1 t2) + D t1 + D t2 + 1"
apply(induction t1 t2 rule: meld2.induct)
apply(auto simp: max_def)
done

lemma plus_log_le_2log_plus: assumes [arith]: "x \<ge> 1" " y\<ge> 1" "b > 1"
shows "log b x + log b y \<le> 2 * log b (x + y)"
proof -
  have 1: "x*y \<le> (x+y)^2"
    by (simp add: numeral_eq_Suc algebra_simps add_increasing)
  have "log b x + log b y = log b (x * y)" by(simp add: log_mult assms)
  also have "\<dots> \<le> log b ((x+y)^2)" by (simp add: 1)
  finally show ?thesis by (simp add: log_nat_power)
qed

lemma amor_le:
  "t\<^sub>m\<^sub>e\<^sub>l\<^sub>d t1 t2 + \<Phi> (meld t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   G(meld t1 t2) + D t1 + D t2 + 1"
apply(induction t1 t2 rule: meld.induct)
apply(auto split: if_splits)
done

lemma a_meld_ub:
  "t\<^sub>m\<^sub>e\<^sub>l\<^sub>d t1 t2 + \<Phi>(meld t1 t2) - \<Phi> t1 - \<Phi> t2 \<le>
   3 * log 2 (size1 t1 + size1 t2) + 1" (is "?l \<le> _")
proof -
  have "?l \<le> G(meld t1 t2) + D t1 + D t2 + 1" using amor_le[of t1 t2] by arith
  also have "\<dots> = real(G(meld t1 t2)) + D t1 + D t2 + 1" by simp
  also have "\<dots> = real(G(meld t1 t2)) + (real(D t1) + D t2) + 1" by simp
  also have "D t1 \<le> log 2 (size1 t1)" by(rule Dlog)
  also have "D t2 \<le> log 2 (size1 t2)" by(rule Dlog)
  also have "G (meld t1 t2) \<le> log 2 (size1(meld t1 t2))" by(rule Glog)
  also have "size1(meld t1 t2) = size1 t1 + size1 t2 - 1" by(simp add: size1_def)
  also have "log 2 (size1 t1 + size1 t2 - 1) \<le> log 2 (size1 t1 + size1 t2)" by(simp add: size1_def)
  also have "log 2 (size1 t1) + log 2 (size1 t2) \<le> 2 * log 2 (real(size1 t1) + (size1 t2))"
    by(rule plus_log_le_2log_plus) (auto simp: size1_def)
  finally show ?thesis by(simp add: real_of_nat_Suc)
qed

datatype 'a op\<^sub>p\<^sub>q = Insert 'a | Delmin

fun nxt\<^sub>p\<^sub>q :: "'a::linorder op\<^sub>p\<^sub>q \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"nxt\<^sub>p\<^sub>q (Insert a) h = Skew_Heap.insert a h" |
"nxt\<^sub>p\<^sub>q Delmin h = del_min h"

fun t\<^sub>p\<^sub>q :: "'a::linorder op\<^sub>p\<^sub>q \<Rightarrow> 'a heap \<Rightarrow> nat" where
"t\<^sub>p\<^sub>q (Insert a) h = t\<^sub>m\<^sub>e\<^sub>l\<^sub>d (Node Leaf a Leaf) h + 1" |
"t\<^sub>p\<^sub>q Delmin h = (case h of Leaf \<Rightarrow> 1 | Node t1 a t2 \<Rightarrow> t\<^sub>m\<^sub>e\<^sub>l\<^sub>d t1 t2 + 1)"

interpretation pq: amor
where init = "Leaf" and nxt = nxt\<^sub>p\<^sub>q
and inv = "\<lambda>_. True"
and t = t\<^sub>p\<^sub>q and \<Phi> = \<Phi>
and U = "\<lambda>f h. case f of
  Insert _ \<Rightarrow> 3 * log 2 (size1 h + 2) + 2 | Delmin \<Rightarrow> 3 * log 2 (size1 h + 2) + 4"
proof
  case goal1 show ?case by auto
next
  case goal2 thus ?case by auto
next
  case goal3 thus ?case by(simp)
next
  case goal4 show ?case by(simp)
next
  case goal5
  show ?case
  proof (cases f)
   case (Insert a)
   thus ?thesis using a_meld_ub[of "Node Leaf a Leaf" "s"]
     by (simp add: numeral_eq_Suc insert_def)
  next
    case Delmin
    thus ?thesis
    proof (cases s)
      case Leaf with Delmin show ?thesis by simp
    next
      case (Node t1 _ t2)
      have [arith]: "log 2 (2 + (real (size t1) + real (size t2))) \<le>
               log 2 (4 + (real (size t1) + real (size t2)))" by simp
      from Delmin Node show ?thesis using a_meld_ub[of t1 t2]
        by (simp add: real_of_nat_Suc size1_def)
    qed
  qed
qed

end


theory regexp_PlusAssociative
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (q :: R) (r :: R) (s :: A list) .
     (recognise (Plus p (Plus q r)) s) =
       (recognise (Plus (Plus p q) r) s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory domain_wall_invariance
imports Link_Algebra
begin

theorem linkrel_domain_invariance: " linkrel a b \<Longrightarrow> domain_wall a = domain_wall b"
proof-
assume 0: "linkrel a b"
have 1:"uncross a b \<Longrightarrow> domain_wall a = domain_wall b"
 proof-
  assume 1:"uncross a b"
  have " domain_wall right_over = domain_wall straight_line" by auto
  then
   have "uncross_positive_straighten a b \<Longrightarrow> domain_wall a = domain_wall b"
   unfolding uncross_positive_straighten_def by metis
  moreover have "domain_wall right_over = domain_wall left_over" using domain_wall.simps by auto
  then have "uncross_positive_flip a b \<Longrightarrow> domain_wall a = domain_wall b"
   unfolding uncross_positive_flip_def by auto
  moreover have "uncross_negative_straighten a b \<Longrightarrow> domain_wall a = domain_wall b"
   unfolding uncross_negative_straighten_def by auto
  moreover have "uncross_negative_flip a b \<Longrightarrow> domain_wall a = domain_wall b"
   unfolding uncross_negative_flip_def by auto
  ultimately have "uncross a b \<Longrightarrow> domain_wall a = domain_wall b"
  unfolding uncross_def by auto
  then show ?thesis using 1 by auto
  qed
have 2:"pull a b \<Longrightarrow> domain_wall a = domain_wall b"
proof-
 assume 1:"pull a b"
 have "pull_negpos a b \<Longrightarrow> domain_wall a = domain_wall b"
  using pull_negpos_def by auto
 moreover have "pull_posneg a b \<Longrightarrow> domain_wall a = domain_wall b"
 using pull_posneg_def by auto
 ultimately show ?thesis  using 1 pull_def by auto
 qed
have 3:"straighten a b \<Longrightarrow> domain_wall a = domain_wall b"
  using straighten_def straighten_topdown_def straighten_downtop_def domain_wall.simps by (metis comm_semiring_1_class.normalizing_semiring_rules(5) compose_Nil domain.simps(2) domain_block.simps(2))

have 4:"rotate a b \<Longrightarrow> domain_wall a = domain_wall b"
proof-
assume 1:"rotate a b"
 have "rotate_toppos a b \<Longrightarrow> domain_wall a = domain_wall b"
  using rotate_toppos_def domain.simps
  by auto
 moreover have "rotate_topneg a b \<Longrightarrow> domain_wall a = domain_wall b"
  using rotate_topneg_def domain.simps
  by auto
  moreover have "rotate_downneg a b \<Longrightarrow> domain_wall a = domain_wall b"
  using rotate_downneg_def domain.simps
  by auto
  moreover have "rotate_downpos a b \<Longrightarrow> domain_wall a = domain_wall b"
  using rotate_downpos_def domain.simps
  by auto
  ultimately show ?thesis using 1 rotate_def by auto
 qed
have 5:"swing a b \<Longrightarrow> domain_wall a = domain_wall b"
 using swing_def swing_pos_def swing_neg_def domain_wall.simps
by (metis
ab_semigroup_add_class.add_ac(1) codomain_wall.cases comm_semiring_1_class.normalizing_semiring_rules(22)
comm_semiring_1_class.normalizing_semiring_rules(23) comm_semiring_1_class.normalizing_semiring_rules(24)
comm_semiring_1_class.normalizing_semiring_rules(5) comm_semiring_1_class.normalizing_semiring_rules(6)
compose_Nil domain_block.simps(1) domain_block.simps(2) wall.distinct(1) wall.size(1) wall.size(2)
wall.size(3) wall.size(4))
have 6:"compress a b \<Longrightarrow> domain_wall a = domain_wall b"
 proof-
 assume 1: "compress a b"
 have "compress_top a b \<Longrightarrow> domain_wall a = domain_wall b"
 using compress_top_def
 proof-
  assume 1: "compress_top a b"
  have "domain_block (make_vert_block (nat (domain_wall B))) = domain_wall B"
     using make_vert_block_def domain_block.simps
      by (metis (full_types) domain_block_nonnegative domain_make_vert domain_wall.simps(1) domain_wall.simps(2) int_nat_eq wall.exhaust)
  then have "domain_wall (basic (make_vert_block (nat (domain_wall B))::block) \<circ> B)
                    = domain_wall (B \<circ> (basic []))"
          by (metis domain_wall.simps(1) domain_wall_compose)
  then have "(\<exists>B. (x = basic (make_vert_block (nat (domain_wall B))) \<circ> B) \<and> (y= B \<circ> basic [] \<and> codomain_wall B = 0))
            \<Longrightarrow> domain_wall x = domain_wall y"
            using exI by (metis (full_types) codomain_wall.cases compose_Nil compose_leftassociativity domain_block_nonnegative domain_make_vert domain_wall.simps(1) domain_wall_compose int_nat_eq wall.distinct(1) wall.exhaust wall.inject(2))
  then have  "(\<exists>B. (x = basic (make_vert_block (nat (domain_wall B))) \<circ> B) \<and> (y= B \<circ> basic [] \<and> codomain_wall B = 0)
         \<and> (codomain_wall B = 0)) \<Longrightarrow> domain_wall x = domain_wall y"
              by auto
  then have "compress_top a b \<Longrightarrow> domain_wall a = domain_wall b"
       using compress_top_def exI
               by (metis codomain_wall.cases compose_Nil domain_block_nonnegative domain_make_vert domain_wall.simps(1) domain_wall_compose int_nat_eq)
  then show ?thesis using 1 by auto
  qed
 moreover have "compress_bottom a b \<Longrightarrow> domain_wall a = domain_wall b"
  using compress_bottom_def domain_wall.simps by (metis domain_block.simps(1) domain_wall_compose)
 ultimately show ?thesis using 1 compress_def by auto
 qed
have 7:"slide a b \<Longrightarrow> domain_wall a = domain_wall b"
 using slide_def
   proof-
   assume 1: "slide a b"
   have "domain_block (make_vert_block (nat (domain_wall B))) = domain_wall B"
        by (metis (full_types) domain_block_nonnegative domain_make_vert domain_wall.simps(1)
         domain_wall.simps(2) int_nat_eq wall.exhaust)
   then have "
  (\<exists>B. (x = basic (make_vert_block (nat (domain_block B))) \<circ> basic B \<and>
       y = basic B \<circ> basic (make_vert_block (nat (codomain_block B)))) \<and>
      domain_block B \<noteq> 0) \<Longrightarrow> (domain_wall x = domain_wall y)"
       using exI domain_wall.simps by (metis domain_block_nonnegative domain_make_vert domain_wall_compose int_nat_eq)
  then have "slide a b \<Longrightarrow> domain_wall a  = domain_wall b"
          unfolding slide_def by (metis domain_block_nonnegative domain_make_vert domain_wall.simps(1) domain_wall_compose int_nat_eq)
  then show ?thesis using 1 by auto
 qed
 then have "linkrel a b \<Longrightarrow> domain_wall a = domain_wall b"
            using 1 2 3 4 5 6 7 linkrel_def by auto
 then show ?thesis using 0 by auto
qed

theorem "x ~ y \<Longrightarrow> domain_wall x = domain_wall y"
proof(induction rule:Tangle_Equivalence.induct)
 case refl
     show ?case by simp
 next
 case equality
     show ?case using linkrel_domain_invariance equality.hyps by auto
 next
 case domain_compose
      show ?case using domain_compose by auto
 next
 case codomain_compose
      show ?case using domain_wall.simps  domain_wall_compose by auto
 next
 case compose_eq
      show ?case  using domain_wall_compose compose_eq.IH by auto
 next
 case sym
      show ?case using sym.IH by auto
 next
 case trans
      show ?case using trans.IH by auto
 next
 case tensor_eq
     show ?case using tensor_domain_wall_additivity tensor_eq.IH by auto
 qed

end


header {* Noninterference for models with finitely many users, commands and outputs *}

(*<*)
theory Finite_Noninterference
imports Noninterference Deep
begin
(*>*)

text{* In the Noninterference section, we showed how to express Goguen-Meseguer
noninterference as a shallow HyperCTL* formula.  Here we show that, if one assumes
finiteness of the sets of users, commands and outputs,
then one can express the property as (the denotation of) a syntactic formula.
Note that we do {\em not} need to assume the state space finite -- this is
important for a potential application to infinite-state systems.  *}

text{* The Goguen-Meseguer security model with finiteness assumptions  *}

locale GM_sec_model_finite = GM_sec_model st0 do out
  for st0 :: 'St
  and do :: "'St \<Rightarrow> 'U \<Rightarrow> 'C \<Rightarrow> 'St"
  and out :: "'St \<Rightarrow> 'U \<Rightarrow> 'Out"
  +
  assumes finite_U: "finite (UNIV :: 'U set)"
  and finite_C: "finite (UNIV :: 'C set)"
  and finite_Out: "finite (UNIV :: 'Out set)"
begin

lemma finite_UminusGH: "finite (UNIV - GH)"
by (metis finite_Diff finite_U)

lemma finite_GL: "finite GL"
by (metis Diff_UNIV finite_Diff2 finite_U)

definition EqOnUC ::
"pvar \<Rightarrow> pvar \<Rightarrow> 'U \<Rightarrow> 'C \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnUC p p' u c \<equiv> Eq (Atom (Last u c) p) (Atom (Last u c) p')"

lemma EqOnUC_eqOnUC[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnUC p p' u c) env = eqOnUC i i' u c"
using assms unfolding EqOnUC_def eqOnUC_def by simp

definition EqButGH ::
"pvar \<Rightarrow> pvar \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqButGH p p' \<equiv> Scon {EqOnUC p p' u c | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}"

lemma finite_EqButGH:
"finite {EqOnUC p p' u c | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}" (is "finite ?K")
proof-
  have 1: "?K = (\<lambda> (u,c). EqOnUC p p' u c) ` ((UNIV - GH) \<times> UNIV)" by auto
  show ?thesis unfolding 1 apply(rule finite_imageI)
  by (metis finite_C finite_SigmaI finite_UminusGH)
qed

lemma EqButGH_eqButGH[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqButGH p p') env = eqButGH i i'"
using assms finite_EqButGH
unfolding EqButGH_def eqButGH_def sem_Scon[OF finite_EqButGH] image_def
by simp (metis (hide_lams, no_types) EqOnUC_eqOnUC)

lemma FV_EqButGH: "FV (EqButGH p p') \<subseteq> {p,p'}" (is "?L \<subseteq> ?R")
proof-
  have "?L = \<Union> {FV (EqOnUC p p' u c) | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}"
  unfolding EqButGH_def FV_Scon[OF finite_EqButGH] by auto
  also have "... \<subseteq> ?R" unfolding EqOnUC_def der_Op_defs by auto
  finally show ?thesis .
qed

definition EqOnUOut ::
"pvar \<Rightarrow> pvar \<Rightarrow> 'U \<Rightarrow> 'Out \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnUOut p p' u ou \<equiv> Eq (Atom (Obs u ou) p) (Atom (Obs u ou) p')"

lemma EqOnUOut_eqOnUOut[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnUOut p p' u ou) env = eqOnUOut i i' u ou"
using assms unfolding EqOnUOut_def eqOnUOut_def by simp

definition EqOnGL ::
"pvar \<Rightarrow> pvar \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnGL p p' \<equiv> Scon {EqOnUOut p p' u ou | u ou. (u,ou) \<in> GL \<times> UNIV}"

lemma finite_EqOnGL:
"finite {EqOnUOut p p' u ou | u ou. (u,ou) \<in> GL \<times> UNIV}" (is "finite ?K")
proof-
  have 1: "?K = (\<lambda> (u,ou). EqOnUOut p p' u ou) ` (GL \<times> UNIV)" by auto
  show ?thesis unfolding 1 apply(rule finite_imageI)
  by (metis finite_Out finite_SigmaI finite_GL)
qed

lemma EqOnGL_eqOnGL[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnGL p p') env = eqOnGL i i'"
using assms finite_EqOnGL
unfolding EqOnGL_def eqOnGL_def sem_Scon[OF finite_EqOnGL] image_def
by simp (metis (hide_lams, no_types) EqOnUOut_eqOnUOut)

lemma FV_EqOnGL: "FV (EqOnGL p p') \<subseteq> {p,p'}" (is "?L \<subseteq> ?R")
proof-
  have "?L = \<Union> {FV (EqOnUOut p p' u ou) | u ou. (u,ou) \<in> GL \<times> UNIV}"
  unfolding EqOnGL_def FV_Scon[OF finite_EqOnGL] by auto
  also have "... \<subseteq> ?R" unfolding EqOnUOut_def der_Op_defs by auto
  finally show ?thesis .
qed

definition "p0 = getFresh {}"
definition "p1 = getFresh {p0}"

lemma p0p1[simp]: "p0 \<noteq> p1" unfolding p1_def
by (metis Diff_cancel getFresh infinite_imp_nonempty infinite_remove insertI1)

definition nonintDfmla :: "('U,'C,'Out) aprop dfmla" where
"nonintDfmla \<equiv>
 Fall2 p0 p1 (Imp (Alw (EqButGH p0 p1)) (Alw (EqOnGL p0 p1)))"

lemma sem_nonintDfmla: "sem nonintDfmla env = nonintSfmla"
unfolding nonintDfmla_def nonintSfmla_def by simp

lemma wff_nonintDfmla[simp]: "wff nonintDfmla"
unfolding nonintDfmla_def Fall2_def Fall_def by simp

lemma closed_nonintDfmla[simp]: "FV nonintDfmla = {}"
unfolding nonintDfmla_def Fall2_def Fall_def der_Op_defs
using FV_EqButGH FV_EqOnGL by fastforce

text{* In the end, we obtain that the semantics of the closed (syntactic) formula
nonintDfmla expresses noninterference faithfully:   *}

theorem semClosed_nonintDfmla: "semClosed nonintDfmla = nonint"
unfolding nonintSfmla_iff_nonint[symmetric]
apply(subst sem_nonintDfmla[symmetric]) apply(rule semClosed_Nil) by auto

(*<*)
end (* context GM_sec_model_finite  *)
(*>*)

text{* end-of-context GM-sec-model-finite  *}

(*<*)
end
(*>*)


(*
    Title:      Examples_Echelon_Form_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Examples of computations using immutable arrays\<close>

theory Examples_Echelon_Form_IArrays
imports
  Echelon_Form_Inverse_IArrays
  "HOL-Library.Code_Target_Numeral"
  Gauss_Jordan.Examples_Gauss_Jordan_Abstract
  Examples_Echelon_Form_Abstract
begin

text\<open>The file @{file \<open>Examples_Echelon_Form_Abstract.thy\<close>} is only imported to
  include the definitions of matrices that we use in the following examples.
  Otherwise, it could be removed.\<close>

subsection\<open>Computing echelon forms, determinants, characteristic polynomials and so on using
  immutable arrays\<close>

subsubsection\<open>Serializing gcd\<close>

text\<open>First of all, we serialize the gcd to the ones of PolyML and MLton as we did in the
  Gauss-Jordan development.\<close>

context
includes integer.lifting
begin

lift_definition gcd_integer :: "integer => integer => integer"
  is "gcd :: int => int => int" .

lemma gcd_integer_code [code]:
"gcd_integer l k = \<bar>if l = (0::integer) then k else gcd_integer l (\<bar>k\<bar> mod \<bar>l\<bar>)\<bar>"
  by transfer (simp add: gcd_code_int [symmetric] ac_simps)

end

code_printing
 constant "abs :: integer => _" \<rightharpoonup> (SML) "IntInf.abs"
 | constant "gcd_integer :: integer => _ => _" \<rightharpoonup> (SML) "(PolyML.IntInf.gcd ((_),(_)))" (*Only for Poly/ML*)
 (* | constant "gcd_integer :: integer => _ => _" \<rightharpoonup> (SML) "(MLton.IntInf.gcd ((_),(_)))"*) (*Only for MLton*)

lemma gcd_code [code]:
  "gcd a b = int_of_integer (gcd_integer (of_int a) (of_int b))"
  by (metis gcd_integer.abs_eq int_of_integer_integer_of_int integer_of_int_eq_of_int)

code_printing
  constant "abs :: real => real" \<rightharpoonup>
    (SML) "Real.abs"

declare [[code drop: "abs :: real \<Rightarrow> real"]]

code_printing
constant "divmod_integer :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.divMod ((_),(_)))"

subsubsection\<open>Examples\<close>

value "det test_int_3x3"

value "det test_int_3x3_03"

value "det test_int_6x6"

value "det test_int_8x8"

value "det test_int_20x20"

value "charpoly test_real_3x3"

value "charpoly test_real_6x6"

value "inverse_matrix test_int_3x3_02"

value "matrix_to_iarray (echelon_form_of test_int_3x3 euclid_ext2)"

value "matrix_to_iarray (echelon_form_of test_int_8x8 euclid_ext2)"

text\<open>The following computations are much faster when code is exported.\<close>

(*value "matrix_to_iarray (echelon_form_of_euclidean test_int_20x20)"*)

(*value "echelon_form_of_iarrays (matrix_to_iarray test_int_20x20) euclid_ext2"*)

(*value "matrix_to_iarray (echelon_form_of test_int_20x20 euclid_ext2)"*)

text\<open>The following matrix will have an integer inverse since its determinant is equal to one\<close>

value "det test_int_3x3_03"

value "the (matrix_to_iarray_option (inverse_matrix test_int_3x3_03))"

text\<open>We check that the previous inverse has been correctly computed:\<close>

value "matrix_matrix_mult_iarray
              (matrix_to_iarray test_int_3x3_03)
              (the (matrix_to_iarray_option (inverse_matrix test_int_3x3_03)))"

value "matrix_matrix_mult_iarray
              (the (matrix_to_iarray_option (inverse_matrix test_int_3x3_03)))
              (matrix_to_iarray test_int_3x3_03)"

text\<open>The following matrices have determinant different from zero,
    and thus do not have an integer inverse\<close>

value "det test_int_6x6"

value "matrix_to_iarray_option (inverse_matrix test_int_6x6)"

value "det test_int_20x20"

value "matrix_to_iarray_option (inverse_matrix test_int_20x20)"

text\<open>The inverse in dimension 20 has (trivial) inverse.\<close>

value "the (matrix_to_iarray_option (inverse_matrix (mat 1::int^20^20)))"

value "the (matrix_to_iarray_option (inverse_matrix (mat 1::int^20^20))) = matrix_to_iarray (mat 1::int^20^20)"

definition "print_echelon_int (A::int^20^20) = echelon_form_of_iarrays (matrix_to_iarray A) euclid_ext2"

text\<open>Performance is better when code is exported. In addition, it depends on the growth of
the integer coefficients of the matrices. For instance, \<open>test_int_20x20\<close>
is a matrix of integer numbers between $-10$ and $10$. The computation of its echelon form (by means
of \<open>print_echelon_int\<close>) needs about 2 seconds. However, the matrix \<open>test_int_20x20_2\<close>
has elements between $0$ and $1010$. The computation of its echelon form (by means
of \<open>print_echelon_int\<close> too) needs about 0.310 seconds. These benchmarks have been carried
out in a laptop with an i5-3360M processor with 4 GB of RAM.\<close>

export_code charpoly det echelon_form_of test_int_8x8 test_int_20x20 test_int_20x20_2 print_echelon_int
  in SML module_name Echelon (*file "Echelon.sml"*)

(*
  PolyML.use "Echelon.sml"; open Echelon; open Timer;
  let val now=startCPUTimer (); in print_echelon_int (test_int_20x20); checkCPUTimes (now) end;
*)

(*Analogously, code can be exported to Haskell using the file Code_Rational presented in the
  Gauss-Jordan AFP entry.*)

end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Prelim.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Preliminaries.
*)

section {* Preliminaries *}

theory Prelim
imports "~~/src/HOL/Library/FSet"
begin

notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

declare fset_to_fset[simp]

lemma fst_snd_convol_o[simp]: "\<langle>fst o s, snd o s\<rangle> = s"
apply(rule ext) by (simp add: convol_def)

abbreviation sm_abbrev (infix "\<oplus>" 60)
where "f \<oplus> g \<equiv> Sum_Type.map_sum f g"

lemma map_sum_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
by (cases z) auto

lemma map_sum_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
by (cases z) auto

abbreviation case_sum_abbrev ("[[_,_]]" 800)
where "[[f,g]] \<equiv> Sum_Type.case_sum f g"

lemma Inl_oplus_elim:
assumes "Inl tr \<in> (id \<oplus> f) ` tns"
shows "Inl tr \<in> tns"
using assms apply clarify by (case_tac x, auto)

lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
using Inl_oplus_elim
by (metis id_def image_iff map_sum.simps(1))

lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
using Inl_oplus_iff unfolding vimage_def by auto

lemma Inr_oplus_elim:
assumes "Inr tr \<in> (id \<oplus> f) ` tns"
shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
using assms apply clarify by (case_tac x, auto)

lemma Inr_oplus_iff[simp]:
"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
apply (rule iffI)
 apply (metis Inr_oplus_elim)
by (metis image_iff map_sum.simps(2))

lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
using Inr_oplus_iff unfolding vimage_def by auto

lemma Inl_Inr_image_cong:
assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
shows "A = B"
apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Domain_T
imports Prefix
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(* for Isabelle 2013
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(***********************************************************
                 type def (Trace Part)
 ***********************************************************)

definition
  HC_T1    :: "'a trace set => bool"
  where
  HC_T1_def : "HC_T1 T == (T ~= {} & prefix_closed T)"

definition "domT  = {T::('a trace set). HC_T1(T)}"
typedef 'a domT = "domT :: 'a trace set set"
(* typedef 'a domT = "{T::('a trace set). HC_T1(T)}" *)
apply (rule_tac x ="{<>}" in exI)
apply (simp add: domT_def)
by (simp add: HC_T1_def prefix_closed_def)

declare Rep_domT         [simp]

(***********************************************************
                   operators on domT
 ***********************************************************)

definition
  memT     :: "'a trace => 'a domT => bool"  ("(_/ :t _)" [50, 51] 50)
  where
  memT_def     : "x :t T     == x : (Rep_domT T)"

definition
  CollectT :: "('a trace => bool) => 'a domT"("CollectT")
  where
  CollectT_def : "CollectT P == Abs_domT (Collect P)"

definition
  UnionT   :: "'a domT set => 'a domT"       ("UnionT _" [90] 90)
  where
  UnionT_def   : "UnionT Ts  == Abs_domT (Union (Rep_domT ` Ts))"

definition
  InterT   :: "'a domT set => 'a domT"       ("InterT _" [90] 90)
  where
  InterT_def   : "InterT Ts  == Abs_domT (Inter (Rep_domT ` Ts))"

definition
  empT     :: "'a domT"                      ("{}t")
  where
  empT_def     : "{}t        == Abs_domT {}"

definition
  UNIVT    :: "'a domT"                      ("UNIVt")
  where
  UNIVT_def    : "UNIVt      == Abs_domT UNIV"

(******** X-symbols ********)
(*
notation (xsymbols) memT ("(_/ \<in>t _)" [50, 51] 50)
notation (xsymbols) UnionT ("\<Union>t _" [90] 90)
notation (xsymbols) InterT ("\<Inter>t _" [90] 90)
*)
(******** syntactic sugar ********)

abbreviation
 nonmemT :: "'a trace => 'a domT => bool"   ("(_/ ~:t _)" [50, 51] 50)
 where "x ~:t T == ~ x :t T"

abbreviation
 UnT :: "'a domT => 'a domT => 'a domT" ("_ UnT _" [65,66] 65)
 where "T UnT S == UnionT {T,S}"

abbreviation
 IntT :: "'a domT => 'a domT => 'a domT" ("_ IntT _" [70,71] 70)
 where "T IntT S == InterT {T,S}"

syntax
  "@CollT"    :: "pttrn => bool => 'a domT"      ("(1{_./ _}t)" [1000,10] 1000)
  "@FindomT"  :: "args => 'a domT"               ("{(_)}t" [1000] 1000)

translations
  "{x. P}t"    == "CONST Abs_domT {x. P}"  (* "CONST" for isabelle2009-2 *)
  "{X}t"       == "CONST Abs_domT {X}"     (* "CONST" for isabelle2009-2 *)

(******** X-symbols ********)
(*
notation (xsymbols) nonmemT ("(_/ \<notin>t _)" [50, 51] 50)
notation (xsymbols) UnT  ("_ \<union>t _" [65,66] 65)
notation (xsymbols) IntT ("_ \<inter>t _" [70,71] 70)
*)
(*********************************************************
          The relation (<=) is defined over domT
 *********************************************************)

instantiation domT :: (type) ord
begin
definition
  subdomT_def:
     "T <= S  ==  (Rep_domT T) <= (Rep_domT S)"
definition
  psubdomT_def:
     "T < S  ==  (Rep_domT T) < (Rep_domT S)"
(*
instance ..
*)
instance
by (intro_classes)
end

(*********************************************************
          The relation (<=) is a partial order
 *********************************************************)

instance domT :: (type) order
apply (intro_classes)
apply (unfold subdomT_def psubdomT_def)
(*apply (simp add: less_fun_def)                (* isabelle 2009-2011 !! *)*)

apply (simp only: order_less_le Rep_domT_inject)
apply (auto simp add: Rep_domT_inject)
done

(***********************************************************
                          lemmas
 ***********************************************************)

(*******************************
             basic
 *******************************)

lemma domT_is_non_empty: "T:domT ==> T ~= {}"
by (simp add: domT_def HC_T1_def)

lemma domT_is_prefix_closed:
  "T:domT ==> prefix_closed T"
by (simp add: domT_def HC_T1_def)

lemma domT_is_prefix_closed_unfold:
  "[| T:domT ; t : T ; prefix s t |] ==> s : T"
apply (simp add: domT_def HC_T1_def)
apply (rule prefix_closed_iff)
by (simp_all)

(*** {<>} in domT ***)

lemma nilt_set_in[simp]: "{<>} : domT"
by (simp add: domT_def HC_T1_def prefix_closed_def)

(*** {<>, <a>} in domT ***)

lemma one_t_set_in[simp]: "{<>,  <a>} : domT"
apply (simp add: domT_def HC_T1_def)
apply (simp add: prefix_closed_def)
apply (intro allI impI)
apply (erule exE)
apply (erule conjE)
apply (erule disjE)
by (simp_all)

(* <> is contained in all domT *)

lemma nilt_in_all_dom: "T : domT ==> <> : T"
apply (simp add: domT_def HC_T1_def)
apply (erule conjE)
apply (subgoal_tac "EX t. t : T")
apply (erule exE)
apply (rule prefix_closed_iff)
by (auto)

(*******************************
        check in domT
 *******************************)

(*** Union ***)

lemma domT_Union_in_domT:
  "Ts ~= {} ==> (Union (Rep_domT ` Ts)) : domT"
apply (simp add: domT_def HC_T1_def)
apply (simp add: prefix_closed_def)
apply (rule conjI)

apply (subgoal_tac "EX T. T : Ts")
apply (erule exE)
apply (rule_tac x="T" in bexI)
apply (simp add: domT_is_non_empty)
apply (simp)
apply (force)

apply (intro allI impI)
apply (elim conjE exE bexE)
apply (rule_tac x="x" in bexI)

apply (rule prefix_closed_iff, simp_all)
apply (rule domT_is_prefix_closed)
apply (simp)
done

(*** Un ***)

lemma domT_Un_in_domT:
  "(Rep_domT T Un Rep_domT S) : domT"
apply (insert domT_Union_in_domT[of "{T,S}"])
by (simp)

(*** Inter ***)

lemma domT_Inter_in_domT:
  "(Inter (Rep_domT ` Ts)) : domT"
apply (simp add: domT_def HC_T1_def)
apply (rule conjI)
apply (subgoal_tac "<> : Inter (Rep_domT ` Ts)", force)
(* apply (simp add: Inter_def)  Isabelle 2012 *)
apply (simp add: nilt_in_all_dom)

apply (simp add: prefix_closed_def)
apply (intro allI impI ballI)
apply (elim conjE exE)
apply (drule_tac x="x" in bspec, simp)

apply (rule prefix_closed_iff, simp_all)
apply (simp add: domT_is_prefix_closed)
done

(*** Int ***)

lemma domT_Int_in_domT:
  "(Rep_domT T Int Rep_domT S) : domT"
apply (insert domT_Inter_in_domT[of "{T,S}"])
by (simp)

lemmas in_domT = domT_Union_in_domT domT_Un_in_domT
                 domT_Inter_in_domT domT_Int_in_domT

(*******************************
    domT type --> set type
 *******************************)

(*** UnionT ***)

(* declare [[simp_trace]] *)

lemma domT_UnionT_Rep:
  "Ts ~= {} ==> Rep_domT (UnionT Ts) = Union (Rep_domT ` Ts)"
apply (simp add: UnionT_def)
apply (simp add: Abs_domT_inverse in_domT)
done

(*** UnT ***)

lemma domT_UnT_Rep:
  "Rep_domT (T UnT S) = (Rep_domT T) Un (Rep_domT S)"
by (simp add: domT_UnionT_Rep)

(*** InterT ***)

lemma domT_InterT_Rep:
  "Rep_domT (InterT Ts) = Inter (Rep_domT ` Ts)"
by (simp add: InterT_def Abs_domT_inverse in_domT)

(*** IntT ***)

lemma domT_IntT_Rep:
  "Rep_domT (T IntT S) = (Rep_domT T) Int (Rep_domT S)"
by (simp add: domT_InterT_Rep)

(*********************************************************
                       memT
 *********************************************************)

(* prefix closed *)

lemma memT_prefix_closed:
  "[| t :t T ; prefix s t |] ==> s :t T"
apply (simp add: memT_def)
apply (rule domT_is_prefix_closed_unfold)
by (simp_all)

(* <> *)

lemma nilt_in_T[simp]: "<> :t T"
by (simp add: memT_def nilt_in_all_dom)

(* UnionT *)

lemma memT_UnionT_only_if:
  "[| Ts ~= {} ; t :t UnionT Ts |] ==> EX T:Ts. t :t T"
by (simp add: memT_def domT_UnionT_Rep)

lemma memT_UnionT_if:
  "[| T:Ts ; t :t T |] ==> t :t UnionT Ts"
apply (subgoal_tac "Ts ~= {}")
apply (simp add: memT_def domT_UnionT_Rep)
apply (rule_tac x="T" in bexI)
by (auto)

lemma memT_UnionT[simp]:
  "Ts ~= {} ==> t :t UnionT Ts = (EX T:Ts. t :t T)"
apply (rule iffI)
apply (simp add: memT_UnionT_only_if)
by (auto simp add: memT_UnionT_if)

(* InterT *)

lemma memT_InterT_only_if:
  "t :t InterT Ts ==> ALL T:Ts. t :t T"
by (simp add: memT_def domT_InterT_Rep)

lemma memT_InterT_if:
  "ALL T:Ts. t :t T ==> t :t InterT Ts"
by (simp add: memT_def domT_InterT_Rep)

lemma memT_InterT[simp]:
  "t :t InterT Ts = (ALL T:Ts. t :t T)"
apply (rule iffI)
apply (rule memT_InterT_only_if, simp_all)
by (simp add: memT_InterT_if)

(* <> *)

lemma memT_nilt[simp]: "t :t {<>}t = (t = <>)"
by (simp add: memT_def Abs_domT_inverse)

(* [e]t, <> *)

lemma memT_nilt_one[simp]: "t :t {<>, <a>}t = (t = <> | t = <a>)"
by (simp add: memT_def Abs_domT_inverse)

(*********************************************************
                       subdomT
 *********************************************************)

lemma subdomTI [intro!]: "(!! t. t :t S ==> t :t T) ==> S <= T"
by (auto simp add: subdomT_def memT_def)

lemma subdomTE [elim!]: "[| S <= T ; (!!t. t :t S ==> t :t T) ==> R |] ==> R"
by (auto simp add: subdomT_def memT_def)

lemma subdomTE_ALL: "[| S <= T ; (ALL t. t :t S --> t :t T) ==> R |] ==> R"
by (auto simp add: subdomT_def memT_def)

lemma subdomT_iff: "((S::'a domT) <= T) = (ALL t. t :t S --> t :t T)"
by (auto)

(*** {<>}t is bottom ***)

lemma BOT_is_bottom_domT[simp]: "{<>}t <= T"
by (simp add: subdomT_iff)

lemma memT_subdomT: "[| t :t S ; S <= T |] ==> t :t T"
by (simp add: subdomT_iff)

(*********************************************************
                         UnT
 *********************************************************)

lemma UnT_commut: "S UnT T = T UnT S"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma UnT_assoc: "(S UnT T) UnT R = S UnT (T UnT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma UnT_left_commut: "S UnT (T UnT R) = T UnT (S UnT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemmas UnT_rules = UnT_commut UnT_assoc UnT_left_commut

lemma UnT_nilt_left[simp]: "{<>}t UnT T = T"
apply (rule order_antisym)
by (auto)

lemma UnT_nilt_right[simp]: "T UnT {<>}t = T"
apply (rule order_antisym)
by (auto)

(*********************************************************
                         IntT
 *********************************************************)

lemma IntT_commut: "S IntT T = T IntT S"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma IntT_assoc: "(S IntT T) IntT R = S IntT (T IntT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemma IntT_left_commut: "S IntT (T IntT R) = T IntT (S IntT R)"
apply (rule order_antisym)
by (simp_all add: subdomT_iff)

lemmas IntT_rules = IntT_commut IntT_assoc IntT_left_commut

(*********************************************************
                         CollectT
 *********************************************************)

(*** open ***)

lemma CollectT_open[simp]: "{u. u :t T}t = T"
apply (subgoal_tac "{u. u :t T} : domT")
apply (auto simp add: memT_def Abs_domT_inverse)
by (simp add: Rep_domT_inverse)

lemma CollectT_open_memT: "{t. P t} : domT ==> t :t {t. P t}t = P t"
by (simp add: memT_def Abs_domT_inverse)

(*** implies {  }t ***)

lemma set_CollectT_eq:
  "{t. Pr1 t} = {t. Pr2 t} ==>{t. Pr1 t}t = {t. Pr2 t}t"
by (simp)

lemma CollectT_eq:
  "[| !! t. Pr1 t = Pr2 t |] ==>{t. Pr1 t}t = {t. Pr2 t}t"
by (simp)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)

declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end