(*  Title:      HOL/Algebra/QuotRing.thy
    Author:     Stephan Hohe
*)

theory QuotRing
imports RingHom
begin

section \<open>Quotient Rings\<close>

subsection \<open>Multiplication on Cosets\<close>

definition rcoset_mult :: "[('a, _) ring_scheme, 'a set, 'a set, 'a set] \<Rightarrow> 'a set"
    ("[mod _:] _ \<Otimes>\<index> _" [81,81,81] 80)
  where "rcoset_mult R I A B = (\<Union>a\<in>A. \<Union>b\<in>B. I +>\<^bsub>R\<^esub> (a \<otimes>\<^bsub>R\<^esub> b))"

text \<open>@{const "rcoset_mult"} fulfils the properties required by
  congruences\<close>
lemma (in ideal) rcoset_mult_add:
    "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> [mod I:] (I +> x) \<Otimes> (I +> y) = I +> (x \<otimes> y)"
  apply rule
  apply (rule, simp add: rcoset_mult_def, clarsimp)
  defer 1
  apply (rule, simp add: rcoset_mult_def)
  defer 1
proof -
  fix z x' y'
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and x'rcos: "x' \<in> I +> x"
    and y'rcos: "y' \<in> I +> y"
    and zrcos: "z \<in> I +> x' \<otimes> y'"

  from x'rcos have "\<exists>h\<in>I. x' = h \<oplus> x"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hx where hxI: "hx \<in> I" and x': "x' = hx \<oplus> x"
    by fast+

  from y'rcos have "\<exists>h\<in>I. y' = h \<oplus> y"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hy where hyI: "hy \<in> I" and y': "y' = hy \<oplus> y"
    by fast+

  from zrcos have "\<exists>h\<in>I. z = h \<oplus> (x' \<otimes> y')"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hz where hzI: "hz \<in> I" and z: "z = hz \<oplus> (x' \<otimes> y')"
    by fast+

  note carr = carr hxI[THEN a_Hcarr] hyI[THEN a_Hcarr] hzI[THEN a_Hcarr]

  from z have "z = hz \<oplus> (x' \<otimes> y')" .
  also from x' y' have "\<dots> = hz \<oplus> ((hx \<oplus> x) \<otimes> (hy \<oplus> y))" by simp
  also from carr have "\<dots> = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" by algebra
  finally have z2: "z = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" .

  from hxI hyI hzI carr have "hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy \<in> I"
    by (simp add: I_l_closed I_r_closed)

  with z2 have "\<exists>h\<in>I. z = h \<oplus> x \<otimes> y" by fast
  then show "z \<in> I +> x \<otimes> y" by (simp add: a_r_coset_def r_coset_def)
next
  fix z
  assume xcarr: "x \<in> carrier R"
    and ycarr: "y \<in> carrier R"
    and zrcos: "z \<in> I +> x \<otimes> y"
  from xcarr have xself: "x \<in> I +> x" by (intro a_rcos_self)
  from ycarr have yself: "y \<in> I +> y" by (intro a_rcos_self)
  show "\<exists>a\<in>I +> x. \<exists>b\<in>I +> y. z \<in> I +> a \<otimes> b"
    using xself and yself and zrcos by fast
qed

subsection \<open>Quotient Ring Definition\<close>

definition FactRing :: "[('a,'b) ring_scheme, 'a set] \<Rightarrow> ('a set) ring"
    (infixl "Quot" 65)
  where "FactRing R I =
    \<lparr>carrier = a_rcosets\<^bsub>R\<^esub> I, mult = rcoset_mult R I,
      one = (I +>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>), zero = I, add = set_add R\<rparr>"

subsection \<open>Factorization over General Ideals\<close>

text \<open>The quotient is a ring\<close>
lemma (in ideal) quotient_is_ring: "ring (R Quot I)"
apply (rule ringI)
   \<comment>\<open>abelian group\<close>
   apply (rule comm_group_abelian_groupI)
   apply (simp add: FactRing_def)
   apply (rule a_factorgroup_is_comm_group[unfolded A_FactGroup_def'])
  \<comment>\<open>mult monoid\<close>
  apply (rule monoidI)
      apply (simp_all add: FactRing_def A_RCOSETS_def RCOSETS_def
             a_r_coset_def[symmetric])
      \<comment>\<open>mult closed\<close>
      apply (clarify)
      apply (simp add: rcoset_mult_add, fast)
     \<comment>\<open>mult \<open>one_closed\<close>\<close>
     apply force
    \<comment>\<open>mult assoc\<close>
    apply clarify
    apply (simp add: rcoset_mult_add m_assoc)
   \<comment>\<open>mult one\<close>
   apply clarify
   apply (simp add: rcoset_mult_add)
  apply clarify
  apply (simp add: rcoset_mult_add)
 \<comment>\<open>distr\<close>
 apply clarify
 apply (simp add: rcoset_mult_add a_rcos_sum l_distr)
apply clarify
apply (simp add: rcoset_mult_add a_rcos_sum r_distr)
done

text \<open>This is a ring homomorphism\<close>

lemma (in ideal) rcos_ring_hom: "(op +> I) \<in> ring_hom R (R Quot I)"
apply (rule ring_hom_memI)
   apply (simp add: FactRing_def a_rcosetsI[OF a_subset])
  apply (simp add: FactRing_def rcoset_mult_add)
 apply (simp add: FactRing_def a_rcos_sum)
apply (simp add: FactRing_def)
done

lemma (in ideal) rcos_ring_hom_ring: "ring_hom_ring R (R Quot I) (op +> I)"
apply (rule ring_hom_ringI)
     apply (rule is_ring, rule quotient_is_ring)
   apply (simp add: FactRing_def a_rcosetsI[OF a_subset])
  apply (simp add: FactRing_def rcoset_mult_add)
 apply (simp add: FactRing_def a_rcos_sum)
apply (simp add: FactRing_def)
done

text \<open>The quotient of a cring is also commutative\<close>
lemma (in ideal) quotient_is_cring:
  assumes "cring R"
  shows "cring (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.intro comm_monoid.intro comm_monoid_axioms.intro)
      apply (rule quotient_is_ring)
     apply (rule ring.axioms[OF quotient_is_ring])
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric])
    apply clarify
    apply (simp add: rcoset_mult_add m_comm)
    done
qed

text \<open>Cosets as a ring homomorphism on crings\<close>
lemma (in ideal) rcos_ring_hom_cring:
  assumes "cring R"
  shows "ring_hom_cring R (R Quot I) (op +> I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (rule ring_hom_cringI)
      apply (rule rcos_ring_hom_ring)
     apply (rule is_cring)
    apply (rule quotient_is_cring)
   apply (rule is_cring)
   done
qed

subsection \<open>Factorization over Prime Ideals\<close>

text \<open>The quotient ring generated by a prime ideal is a domain\<close>
lemma (in primeideal) quotient_is_domain: "domain (R Quot I)"
  apply (rule domain.intro)
   apply (rule quotient_is_cring, rule is_cring)
  apply (rule domain_axioms.intro)
   apply (simp add: FactRing_def) defer 1
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarify)
    apply (simp add: rcoset_mult_add) defer 1
proof (rule ccontr, clarsimp)
  assume "I +> \<one> = I"
  then have "\<one> \<in> I" by (simp only: a_coset_join1 one_closed a_subgroup)
  then have "carrier R \<subseteq> I" by (subst one_imp_carrier, simp, fast)
  with a_subset have "I = carrier R" by fast
  with I_notcarr show False by fast
next
  fix x y
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and a: "I +> x \<otimes> y = I"
    and b: "I +> y \<noteq> I"

  have ynI: "y \<notin> I"
  proof (rule ccontr, simp)
    assume "y \<in> I"
    then have "I +> y = I" by (rule a_rcos_const)
    with b show False by simp
  qed

  from carr have "x \<otimes> y \<in> I +> x \<otimes> y" by (simp add: a_rcos_self)
  then have xyI: "x \<otimes> y \<in> I" by (simp add: a)

  from xyI and carr have xI: "x \<in> I \<or> y \<in> I" by (simp add: I_prime)
  with ynI have "x \<in> I" by fast
  then show "I +> x = I" by (rule a_rcos_const)
qed

text \<open>Generating right cosets of a prime ideal is a homomorphism
        on commutative rings\<close>
lemma (in primeideal) rcos_ring_hom_cring: "ring_hom_cring R (R Quot I) (op +> I)"
  by (rule rcos_ring_hom_cring) (rule is_cring)

subsection \<open>Factorization over Maximal Ideals\<close>

text \<open>In a commutative ring, the quotient ring over a maximal ideal
        is a field.
        The proof follows ``W. Adkins, S. Weintraub: Algebra --
        An Approach via Module Theory''\<close>
lemma (in maximalideal) quotient_is_field:
  assumes "cring R"
  shows "field (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.cring_fieldI2)
      apply (rule quotient_is_cring, rule is_cring)
     defer 1
     apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarsimp)
     apply (simp add: rcoset_mult_add) defer 1
  proof (rule ccontr, simp)
    \<comment>\<open>Quotient is not empty\<close>
    assume "\<zero>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot I\<^esub>"
    then have II1: "I = I +> \<one>" by (simp add: FactRing_def)
    from a_rcos_self[OF one_closed] have "\<one> \<in> I"
      by (simp add: II1[symmetric])
    then have "I = carrier R" by (rule one_imp_carrier)
    with I_notcarr show False by simp
  next
    \<comment>\<open>Existence of Inverse\<close>
    fix a
    assume IanI: "I +> a \<noteq> I" and acarr: "a \<in> carrier R"

    \<comment>\<open>Helper ideal \<open>J\<close>\<close>
    define J :: "'a set" where "J = (carrier R #> a) <+> I"
    have idealJ: "ideal J R"
      apply (unfold J_def, rule add_ideals)
       apply (simp only: cgenideal_eq_rcos[symmetric], rule cgenideal_ideal, rule acarr)
      apply (rule is_ideal)
      done

    \<comment>\<open>Showing @{term "J"} not smaller than @{term "I"}\<close>
    have IinJ: "I \<subseteq> J"
    proof (rule, simp add: J_def r_coset_def set_add_defs)
      fix x
      assume xI: "x \<in> I"
      have Zcarr: "\<zero> \<in> carrier R" by fast
      from xI[THEN a_Hcarr] acarr
      have "x = \<zero> \<otimes> a \<oplus> x" by algebra
      with Zcarr and xI show "\<exists>xa\<in>carrier R. \<exists>k\<in>I. x = xa \<otimes> a \<oplus> k" by fast
    qed

    \<comment>\<open>Showing @{term "J \<noteq> I"}\<close>
    have anI: "a \<notin> I"
    proof (rule ccontr, simp)
      assume "a \<in> I"
      then have "I +> a = I" by (rule a_rcos_const)
      with IanI show False by simp
    qed

    have aJ: "a \<in> J"
    proof (simp add: J_def r_coset_def set_add_defs)
      from acarr
      have "a = \<one> \<otimes> a \<oplus> \<zero>" by algebra
      with one_closed and additive_subgroup.zero_closed[OF is_additive_subgroup]
      show "\<exists>x\<in>carrier R. \<exists>k\<in>I. a = x \<otimes> a \<oplus> k" by fast
    qed

    from aJ and anI have JnI: "J \<noteq> I" by fast

    \<comment>\<open>Deducing @{term "J = carrier R"} because @{term "I"} is maximal\<close>
    from idealJ and IinJ have "J = I \<or> J = carrier R"
    proof (rule I_maximal, unfold J_def)
      have "carrier R #> a \<subseteq> carrier R"
        using subset_refl acarr by (rule r_coset_subset_G)
      then show "carrier R #> a <+> I \<subseteq> carrier R"
        using a_subset by (rule set_add_closed)
    qed

    with JnI have Jcarr: "J = carrier R" by simp

    \<comment>\<open>Calculating an inverse for @{term "a"}\<close>
    from one_closed[folded Jcarr]
    have "\<exists>r\<in>carrier R. \<exists>i\<in>I. \<one> = r \<otimes> a \<oplus> i"
      by (simp add: J_def r_coset_def set_add_defs)
    then obtain r i where rcarr: "r \<in> carrier R"
      and iI: "i \<in> I" and one: "\<one> = r \<otimes> a \<oplus> i" by fast
    from one and rcarr and acarr and iI[THEN a_Hcarr]
    have rai1: "a \<otimes> r = \<ominus>i \<oplus> \<one>" by algebra

    \<comment>\<open>Lifting to cosets\<close>
    from iI have "\<ominus>i \<oplus> \<one> \<in> I +> \<one>"
      by (intro a_rcosI, simp, intro a_subset, simp)
    with rai1 have "a \<otimes> r \<in> I +> \<one>" by simp
    then have "I +> \<one> = I +> a \<otimes> r"
      by (rule a_repr_independence, simp) (rule a_subgroup)

    from rcarr and this[symmetric]
    show "\<exists>r\<in>carrier R. I +> a \<otimes> r = I +> \<one>" by fast
  qed
qed

end


theory Sep_Lift
imports Sep_Generic_Wp "HOL-Library.Rewrite"
begin

  locale sep_lifting_scheme =
    fixes lift :: "'asmall::unique_zero_sep_algebra \<Rightarrow> 'abig::unique_zero_sep_algebra"
      and project :: "'abig \<Rightarrow> 'asmall"
      and carve :: "'abig \<Rightarrow> 'abig"
      and splittable :: "'abig \<Rightarrow> bool"
    assumes lift_pres_zero[simp]: "lift 0 = 0"
        and lift_add_distrib[simp]: "a\<^sub>1##a\<^sub>2 \<Longrightarrow> lift (a\<^sub>1+a\<^sub>2) = lift a\<^sub>1 + lift a\<^sub>2"
        and lift_disj_distrib[simp]: "lift a\<^sub>1 ## lift a\<^sub>2 \<longleftrightarrow> a\<^sub>1##a\<^sub>2"

    assumes splittable_lift[simp]: "splittable (lift a)"
        and splittable_same_struct: "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; project b\<^sub>1\<noteq>0\<rbrakk> \<Longrightarrow> splittable b\<^sub>2"
        (*and splittable_same_struct: "\<lbrakk>b\<^sub>1##b\<^sub>2; b\<^sub>1\<noteq>0; b\<^sub>2\<noteq>0\<rbrakk> \<Longrightarrow> splittable b\<^sub>2 = splittable b\<^sub>1"*)
        and splittable_add_distrib[simp]: "\<lbrakk>b\<^sub>1##b\<^sub>2\<rbrakk> \<Longrightarrow> splittable (b\<^sub>1 + b\<^sub>2) \<longleftrightarrow> splittable b\<^sub>1 \<and> splittable b\<^sub>2"

    assumes project_pres_zero[simp]: "project 0 = 0"
    assumes project_add_distrib[simp]:
          "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; splittable b\<^sub>2\<rbrakk> \<Longrightarrow> project (b\<^sub>1 + b\<^sub>2) = project b\<^sub>1 + project b\<^sub>2"
        and project_disj_distrib[simp]: "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; splittable b\<^sub>2\<rbrakk> \<Longrightarrow> project b\<^sub>1 ## project b\<^sub>2"
    assumes carve_pres_zero[simp]: "carve 0 = 0"
    assumes carve_add_distrib[simp]: "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; splittable b\<^sub>2\<rbrakk> \<Longrightarrow> carve (b\<^sub>1 + b\<^sub>2) = carve b\<^sub>1 + carve b\<^sub>2"
        and carve_disj_distrib[simp]: "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; splittable b\<^sub>2\<rbrakk> \<Longrightarrow> carve b\<^sub>1 ## carve b\<^sub>2"

    assumes project_lift_id[simp]: "project (lift a) = a"
    assumes project_carve_Z[simp]: "splittable b \<Longrightarrow> project (carve b) = 0"
    assumes carve_lift_Z[simp]: "carve (lift a) = 0"

    assumes disj_project_imp_lift: "splittable b \<Longrightarrow> a ## project b \<Longrightarrow> lift a ## b"
    assumes carve_disj_lift1: "splittable b \<Longrightarrow> carve b ## lift a"

    assumes complete_split: "splittable b \<Longrightarrow> lift (project b) + carve b = b"

    assumes carve_not_splittable[simp]: "\<not> splittable b \<Longrightarrow> carve b = b"
      \<comment> \<open>We force carve to be identity outside splittable range.
        This is an arbitrary fixation of an otherwise unspecified value, which makes
        some properties simpler to prove (e.g. assoc of composition)
        \<close>
  begin
    lemma splittableZ[simp]: "splittable 0"
      by (metis lift_pres_zero splittable_lift)

    lemma splittable_carve_if[simp]: " splittable p \<Longrightarrow> splittable (carve p)"
      by (metis carve_disj_lift1 complete_split sep_add_commute splittable_add_distrib)

    lemma carve_disj_lift[simp]:
      assumes "splittable b"
      shows "carve b ## lift a" "lift a ## carve b"
      using carve_disj_lift1 carve_disj_lift1[THEN sep_disj_commuteI] assms by auto

    lemma lift_eqZ_iffZ[simp]: "lift a = 0 \<longleftrightarrow> a=0"
      by (metis lift_pres_zero project_lift_id)

    lemma carve_smaller1: "splittable p \<Longrightarrow> p ## f \<Longrightarrow> carve p ## f"
      by (metis carve_disj_lift(2) sep_add_disjD complete_split)

    lemmas carve_smaller[simp] = carve_smaller1 carve_smaller1[THEN sep_disj_commuteI]

    lemma disj_project_eq_lift1:
      "splittable b \<Longrightarrow> a ## project b \<longleftrightarrow> lift a ## b"
      using disj_project_imp_lift project_disj_distrib by fastforce

    lemma disj_project_eq_lift2:
      "splittable b \<Longrightarrow> project b ## a \<longleftrightarrow> b ## lift a"
      by (meson disj_project_eq_lift1 sep_disj_commuteI)

    lemmas disj_project_eq_lift = disj_project_eq_lift1 disj_project_eq_lift2

    (*
    lemma proj_Z_imp_disj1:
      assumes "project b = 0"
      shows "lift a ## b"
      by (simp add: assms disj_project_imp_lift)

    lemmas proj_Z_imp_disj[simp] = proj_Z_imp_disj1 proj_Z_imp_disj1[THEN sep_disj_commuteI]
    *)

    lemmas split_complete = complete_split[symmetric]

    lemma projectZ_add_distrib[simp]:
      "\<lbrakk>b\<^sub>1##b\<^sub>2; splittable b\<^sub>1; splittable b\<^sub>2\<rbrakk> \<Longrightarrow> project (b\<^sub>1 + b\<^sub>2) = 0 \<longleftrightarrow> project b\<^sub>1=0 \<and> project b\<^sub>2=0"
      by (auto simp: )

    lemma project_add_invE:
      assumes "project b = a\<^sub>1 + a\<^sub>2" "splittable b" "a\<^sub>1##a\<^sub>2"
      obtains b\<^sub>1 b\<^sub>2 where "b\<^sub>1##b\<^sub>2" "b=b\<^sub>1+b\<^sub>2" "project b\<^sub>1 = a\<^sub>1" "project b\<^sub>2 = a\<^sub>2" "splittable b\<^sub>1" "splittable b\<^sub>2"
      using assms
      by (smt lift_add_distrib lift_disj_distrib project_add_distrib project_carve_Z project_lift_id sep_add_assoc sep_lifting_scheme.carve_disj_lift(2) sep_lifting_scheme.disj_project_eq_lift1 sep_lifting_scheme_axioms split_complete splittable_add_distrib)

    lemma carve_project_Z_imp_Z: "\<lbrakk>carve x = 0; project x = 0\<rbrakk> \<Longrightarrow> x = 0"
      by (metis carve_not_splittable carve_pres_zero complete_split project_pres_zero splittableZ)

  end

  record ('asmall,'csmall,'tsmall,'abig,'cbig,'tbig) sep_lifter =
    lift :: "'asmall::unique_zero_sep_algebra \<Rightarrow> 'abig::unique_zero_sep_algebra"
    project :: "'abig \<Rightarrow> 'asmall"
    carve :: "'abig \<Rightarrow> 'abig"
    splittable :: "'abig \<Rightarrow> bool"

    L :: "'csmall \<Longrightarrow> 'cbig"
    \<alpha>b :: "'cbig \<Rightarrow> 'abig"
    \<alpha>s :: "'csmall \<Rightarrow> 'asmall"

    tyb :: "'cbig \<Rightarrow> 'tbig"
    tys :: "'csmall \<Rightarrow> 'tsmall"

  hide_const (open) lift project carve splittable L \<alpha>b \<alpha>s tyb tys

  locale pre_sep_lifter =
    fixes LFT :: "('asmall::unique_zero_sep_algebra,'csmall,'tsmall,'abig::unique_zero_sep_algebra,'cbig,'tbig) sep_lifter"
  begin
    abbreviation lift where "lift \<equiv> sep_lifter.lift LFT"
    abbreviation project where "project \<equiv> sep_lifter.project LFT"
    abbreviation carve where "carve \<equiv> sep_lifter.carve LFT"
    abbreviation splittable where "splittable \<equiv> sep_lifter.splittable LFT"
    abbreviation L where "L \<equiv> sep_lifter.L LFT"
    abbreviation \<alpha>b where "\<alpha>b \<equiv> sep_lifter.\<alpha>b LFT"
    abbreviation \<alpha>s where "\<alpha>s \<equiv> sep_lifter.\<alpha>s LFT"
    abbreviation tyb where "tyb \<equiv> sep_lifter.tyb LFT"
    abbreviation tys where "tys \<equiv> sep_lifter.tys LFT"

    definition "lift_assn P b \<equiv> splittable b \<and> carve b = 0 \<and> (P (project b))"

  end

  locale sep_lifter = pre_sep_lifter LFT + sep_lifting_scheme lift project carve splittable
    for LFT :: "('asmall::unique_zero_sep_algebra,'csmall,'tsmall,'abig::unique_zero_sep_algebra,'cbig,'tbig) sep_lifter" +

    assumes lensL[simp, intro!]: "hlens L"
    assumes precond: "\<lbrakk>splittable (\<alpha>b cb); project (\<alpha>b cb)\<noteq>0\<rbrakk> \<Longrightarrow> pre_get L cb \<and> pre_put L cb"
    assumes get_xfer[simp]: "\<lbrakk>splittable (\<alpha>b cb); project (\<alpha>b cb)\<noteq>0\<rbrakk> \<Longrightarrow> \<alpha>s (get' L cb) = project (\<alpha>b cb)"
    assumes put_xfer[simp]: "\<lbrakk>splittable (\<alpha>b cb); project (\<alpha>b cb)\<noteq>0; tys x = tys (get' L cb)\<rbrakk>
      \<Longrightarrow> \<alpha>b (put' L x cb) = lift (\<alpha>s x) + carve (\<alpha>b cb)"

    assumes ty_put_xfer[simp]: "\<lbrakk>pre_get L cb; tys x = tys (get' L cb) \<rbrakk> \<Longrightarrow> tyb (put' L x cb) = tyb cb"

  begin

    declare sep_lifter_axioms[simp, intro!]

    lemma lift_assn_distrib[simp]: "lift_assn (P**Q) = (lift_assn P ** lift_assn Q)"
      apply (rule ext)
      apply (auto simp: sep_conj_def lift_assn_def)
      apply (erule project_add_invE; auto)
      apply force
      done

    lemma lift_assn_EXACT_eq[simp]: "lift_assn (EXACT v) = EXACT (lift v)"
      apply (rule ext)
      apply (auto simp: lift_assn_def)
      using split_complete by fastforce

    lemma lift_assn_pure[simp]: "lift_assn (\<up>\<Phi>) = \<up>\<Phi>"
      apply (rule ext)
      unfolding lift_assn_def
      by (auto simp: pred_lift_extract_simps intro: carve_project_Z_imp_Z)

    lemma lift_assn_empty[simp]: "lift_assn \<box> = \<box>"
      apply (rule ext)
      unfolding lift_assn_def
      by (auto simp: sep_algebra_simps intro: carve_project_Z_imp_Z)

    lemma lift_ty:
      assumes PRESTY: "\<And>s. wlp c (\<lambda>_ s'. tys s' = tys s) s"
      shows "wlp (zoom (lift_lens e L) c) (\<lambda>_ s'. tyb s' = tyb s) s"
      using PRESTY
      apply (auto simp: wlp_def run_simps split: option.splits)
      apply (drule meta_spec[where x="get' L s"])
      apply (erule mwp_cons)
      apply (auto)
      done

    lemma infer_pre_get_with_frame:
      assumes "lift_assn P p" "p ## f"  "\<alpha>b s = p + f"
      assumes NZ: "\<not>P 0"
      shows "pre_get L s"
      apply (rule precond[THEN conjunct1])
      using assms splittable_same_struct unfolding lift_assn_def
      by fastforce+

    lemma lift_operation:
      assumes NZ: "\<not>P 0"
      assumes PRESTY: "\<And>s. wlp c (\<lambda>_ s'. tys s' = tys s) s"
      assumes HT: "htriple \<alpha>s P c Q"
      shows "htriple \<alpha>b (lift_assn P) (zoom (lift_lens e L) c) (\<lambda>r. lift_assn (Q r))"
    proof (rule htripleI'; clarsimp simp: lift_assn_def)
      fix p s f
      assume A: "p ## f" and [simp]: "\<alpha>b s = p + f" "splittable p" "carve p = 0" and "P (project p)"
      hence [simp]: "project p\<noteq>0" "p\<noteq>0" "p##f" "f##p" using NZ by (auto simp: sep_algebra_simps)

      have [simp]: "splittable f"
        using A \<open>project p \<noteq> 0\<close> \<open>splittable p\<close> splittable_same_struct by blast

      from A have OFR: "\<alpha>b s = lift (project (p + f)) + carve (p+f)"
        apply (rewrite in "_ = \<hole>" complete_split)
        by simp_all

      have [simp]: "project (\<alpha>b s) \<noteq> 0" using A by simp

      note HT'= htripleD'[OF HT _ _ \<open>P (project p)\<close>, where f="project f" and s="get' L s", simplified]

      from PRESTY HT' have HT':
        "wp c (\<lambda>r s'. tys s' = tys (get' L s) \<and> (\<exists>p'. p' ## project f \<and> \<alpha>s s' = p' + project f \<and> Q r p')) (get' L s)"
        apply (auto simp: wlp_def wp_def mwp_def split: mres.splits)
        apply (drule meta_spec[where x="get' L s"]; simp) (* FIXME: Why can't we solve that goal in one line? *)
        done

      note HT' = HT'[unfolded wp_def]

      (*from precond have [simp]: "pre_get L s" "pre_put L s" by auto*)
      note [simp] = precond

      show "wp (zoom (lift_lens e L) c) (\<lambda>r s'. \<exists>p'. p' ## f \<and> \<alpha>b s' = p' + f \<and> splittable p' \<and> carve p' = 0 \<and> Q r (project p')) s"
        apply (auto simp: wp_def run_simps split: option.splits)
        apply (rule mwp_cons[OF HT'])
        apply (clarsimp_all simp: )
        subgoal for x s' p'
          apply (intro exI[where x="lift p' + carve p"])
          apply (auto simp: disj_project_eq_lift sep_algebra_simps)
          apply (rewrite in "_=\<hole>" split_complete[of f])
          apply (auto simp: disj_project_eq_lift sep_algebra_simps)
          done
        done
    qed

  end

  definition "list\<alpha> \<alpha> l i \<equiv> if i<length l then \<alpha> (l!i) else (0::_::unique_zero_sep_algebra)"

  lemma list\<alpha>_Nil[simp]: "list\<alpha> \<alpha> [] = 0"
    by (auto simp: list\<alpha>_def)

  lemma list\<alpha>_upd[simp]:
    "i<length xs \<Longrightarrow> list\<alpha> \<alpha> (xs[i := x]) = (list\<alpha> \<alpha> xs)(i:=\<alpha> x)"
    by (rule ext) (auto simp: list\<alpha>_def)

  definition "idx_lifter tys \<alpha>s i \<equiv> \<lparr>
    sep_lifter.lift = fun_upd (\<lambda>x. 0) i,
    sep_lifter.project = (\<lambda>f. f i),
    sep_lifter.carve = (\<lambda>f. f(i:=0)),
    sep_lifter.splittable = (\<lambda>f. True),
    sep_lifter.L = idx\<^sub>L i,
    sep_lifter.\<alpha>b = list\<alpha> \<alpha>s,
    sep_lifter.\<alpha>s = \<alpha>s,
    sep_lifter.tyb = map tys,
    sep_lifter.tys = tys
        \<rparr>"

  lemma idx_lifter_simps[simp]:
    "sep_lifter.lift (idx_lifter tys \<alpha>s i) = fun_upd (\<lambda>x. 0) i"
    "sep_lifter.project (idx_lifter tys \<alpha>s i) = (\<lambda>f. f i)"
    "sep_lifter.carve (idx_lifter tys \<alpha>s i) = (\<lambda>f. f(i:=0))"
    "sep_lifter.splittable (idx_lifter tys \<alpha>s i) = (\<lambda>f. True)"
    "sep_lifter.L (idx_lifter tys \<alpha>s i) = idx\<^sub>L i"
    "sep_lifter.\<alpha>b (idx_lifter tys \<alpha>s i) = list\<alpha> \<alpha>s"
    "sep_lifter.\<alpha>s (idx_lifter tys \<alpha>s i) = \<alpha>s"
    "sep_lifter.tyb (idx_lifter tys \<alpha>s i) = map tys"
    "sep_lifter.tys (idx_lifter tys \<alpha>s i) = tys"
    unfolding idx_lifter_def by auto

  lemma idx_lifter[simp, intro!]: "sep_lifter (idx_lifter tys \<alpha>s i)"
    apply unfold_locales
    apply (simp_all add: idx_lifter_def)
    apply (auto simp: sep_algebra_simps)
    apply (auto simp: sep_disj_fun_def sep_algebra_simps intro!: exI[where x="f(i:=0::'a)" for f])
    apply (auto simp: list\<alpha>_def[abs_def] nth_list_update map_upd_eq split: if_splits)
    done

  fun option\<alpha> :: "('c \<Rightarrow> 'a) \<Rightarrow> 'c option \<Rightarrow> 'a::unique_zero_sep_algebra"
    where "option\<alpha> \<alpha> None = 0" | "option\<alpha> \<alpha> (Some x) = \<alpha> x"

  lemma option\<alpha>_alt: "option\<alpha> \<alpha> x = (case x of None \<Rightarrow> 0 | Some y \<Rightarrow> \<alpha> y)" by (cases x) auto

  definition "option_lifter tys \<alpha>s \<equiv> \<lparr>
    sep_lifter.lift = id,
    sep_lifter.project = id,
    sep_lifter.carve = \<lambda>_. 0,
    sep_lifter.splittable = (\<lambda>f. True),
    sep_lifter.L = the\<^sub>L,
    sep_lifter.\<alpha>b = option\<alpha> \<alpha>s,
    sep_lifter.\<alpha>s = \<alpha>s,
    sep_lifter.tyb = map_option tys,
    sep_lifter.tys = tys
  \<rparr>"

  lemma option_lifter_simps[simp]:
    "sep_lifter.lift (option_lifter tys \<alpha>s) = id"
    "sep_lifter.project (option_lifter tys \<alpha>s) = id"
    "sep_lifter.carve (option_lifter tys \<alpha>s) = (\<lambda>_. 0)"
    "sep_lifter.splittable (option_lifter tys \<alpha>s) = (\<lambda>f. True)"
    "sep_lifter.L (option_lifter tys \<alpha>s) = the\<^sub>L"
    "sep_lifter.\<alpha>b (option_lifter tys \<alpha>s) = option\<alpha> \<alpha>s"
    "sep_lifter.\<alpha>s (option_lifter tys \<alpha>s) = \<alpha>s"
    "sep_lifter.tyb (option_lifter tys \<alpha>s) = map_option tys"
    "sep_lifter.tys (option_lifter tys \<alpha>s) = tys"
    unfolding option_lifter_def by auto

  lemma option_lifter[simp, intro!]: "sep_lifter (option_lifter tys \<alpha>s)"
    apply unfold_locales
    apply (auto simp: option_lifter_def)
    apply (auto simp: option\<alpha>_alt split: option.splits)
    done

  definition "compose_splittable l\<^sub>1 l\<^sub>2 \<equiv> (\<lambda>x. sep_lifter.splittable l\<^sub>2 x \<and> sep_lifter.splittable l\<^sub>1 (sep_lifter.project l\<^sub>2 x))"

  definition "compose_carve l\<^sub>1 l\<^sub>2 \<equiv> \<lambda>x.
    if compose_splittable l\<^sub>1 l\<^sub>2 x then
      sep_lifter.carve l\<^sub>2 x + sep_lifter.lift l\<^sub>2 ( sep_lifter.carve l\<^sub>1 (sep_lifter.project l\<^sub>2 x))
    else x"

  definition
    compose_lifter ::
    "('as::unique_zero_sep_algebra,'cs,'ts,'ab::unique_zero_sep_algebra,'cb,'tb) sep_lifter
      \<Rightarrow> ('ab,'cb,'tb,'al::unique_zero_sep_algebra,'cl,'tl) sep_lifter
      \<Rightarrow> ('as, 'cs, 'ts, 'al, 'cl, 'tl) sep_lifter"
    (infixl "\<bullet>\<^sub>l\<^sub>f\<^sub>t" 80)
  where "compose_lifter l\<^sub>1 l\<^sub>2 \<equiv> \<lparr>
    sep_lifter.lift = sep_lifter.lift l\<^sub>2 o sep_lifter.lift l\<^sub>1,
    sep_lifter.project = sep_lifter.project l\<^sub>1 o sep_lifter.project l\<^sub>2,
    sep_lifter.carve = compose_carve l\<^sub>1 l\<^sub>2,
    sep_lifter.splittable = compose_splittable l\<^sub>1 l\<^sub>2,
    sep_lifter.L = sep_lifter.L l\<^sub>2 \<bullet>\<^sub>L sep_lifter.L l\<^sub>1,
    sep_lifter.\<alpha>b = sep_lifter.\<alpha>b l\<^sub>2,
    sep_lifter.\<alpha>s = sep_lifter.\<alpha>s l\<^sub>1,
    sep_lifter.tyb = sep_lifter.tyb l\<^sub>2,
    sep_lifter.tys = sep_lifter.tys l\<^sub>1
  \<rparr>"

  lemma compose_lifter_simps:
    "sep_lifter.lift (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.lift l\<^sub>2 o sep_lifter.lift l\<^sub>1"
    "sep_lifter.project (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.project l\<^sub>1 o sep_lifter.project l\<^sub>2"
    "sep_lifter.carve (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = compose_carve l\<^sub>1 l\<^sub>2"
    "sep_lifter.splittable (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = compose_splittable l\<^sub>1 l\<^sub>2"
    "sep_lifter.L (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.L l\<^sub>2 \<bullet>\<^sub>L sep_lifter.L l\<^sub>1"
    "sep_lifter.\<alpha>b (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.\<alpha>b l\<^sub>2"
    "sep_lifter.\<alpha>s (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.\<alpha>s l\<^sub>1"
    "sep_lifter.tyb (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.tyb l\<^sub>2"
    "sep_lifter.tys (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) = sep_lifter.tys l\<^sub>1"
    unfolding compose_lifter_def by auto

  lemma compose_sep_lifter[simp, intro!]:
    fixes l\<^sub>1 :: "('as::unique_zero_sep_algebra, 'cs, 'ts, 'ab::unique_zero_sep_algebra, 'cb, 'tb) sep_lifter"
      and l\<^sub>2 :: "('ab, 'cb, 'tb, 'al::unique_zero_sep_algebra, 'cl, 'tl) sep_lifter"
    assumes "sep_lifter l\<^sub>1"
    assumes "sep_lifter l\<^sub>2"
    assumes \<alpha>EQ: "sep_lifter.\<alpha>s l\<^sub>2 = sep_lifter.\<alpha>b l\<^sub>1"
    assumes tEQ: "sep_lifter.tys l\<^sub>2 = sep_lifter.tyb l\<^sub>1"
    shows "sep_lifter (compose_lifter l\<^sub>1 l\<^sub>2)"
  proof -
    interpret l1: sep_lifter l\<^sub>1 by fact
    interpret l2: sep_lifter l\<^sub>2 by fact

    show ?thesis
      apply unfold_locales
      apply (clarsimp_all
        simp: compose_lifter_def compose_carve_def compose_splittable_def
        simp: sep_algebra_simps
        )
      subgoal for b1 b2
        using l1.splittable_same_struct l2.splittable_same_struct by force

      subgoal for b1 b2 by auto
      subgoal by (clarsimp simp: l1.disj_project_eq_lift l2.disj_project_eq_lift sep_algebra_simps)
      subgoal
        apply (rewrite at "_=\<hole>" l2.split_complete, assumption)
        apply (rewrite in "_=\<hole>" l1.split_complete, assumption)
        by (auto simp: sep_algebra_simps)
      proof goal_cases
        fix cb
        assume A:
          "l1.project (l2.project (l2.\<alpha>b cb)) \<noteq> 0"
          "l2.splittable (l2.\<alpha>b cb)"
          "l1.splittable (l2.project (l2.\<alpha>b cb))"
        then show "pre_get l2.L cb \<and> pre_get l1.L (get' l2.L cb)"
          using \<alpha>EQ l2.precond l1.sep_lifter_axioms l2.sep_lifter_axioms sep_lifter.get_xfer sep_lifter.precond
          by fastforce

        hence [simp]: "pre_get l2.L cb" "pre_get l1.L (get' l2.L cb)" by auto

        from A show "l1.\<alpha>s (get' (l2.L \<bullet>\<^sub>L l1.L) cb) = l1.project (l2.project (l2.\<alpha>b cb))"
          using \<alpha>EQ l2.sep_lifter_axioms sep_lifter.get_xfer by fastforce

        fix x
        assume "l1.tys x = l1.tys (get' (l2.L \<bullet>\<^sub>L l1.L) cb)"
        with A show "l2.\<alpha>b (put' (l2.L \<bullet>\<^sub>L l1.L) x cb) =
            l2.carve (l2.\<alpha>b cb)
          + (l2.lift (l1.lift (l1.\<alpha>s x))
              + l2.lift (l1.carve (l2.project (l2.\<alpha>b cb))))"
          apply (auto)
          apply (subst l2.put_xfer) apply (auto simp: tEQ) [3]
          apply (subst l1.put_xfer[folded \<alpha>EQ]; (subst l2.get_xfer)?; auto)
          apply (auto simp: sep_algebra_simps)
          done

      qed (simp add: tEQ)

  qed

  lemma compose_lifter_assoc[simp]:
    assumes "sep_lifter l\<^sub>1" "sep_lifter l\<^sub>2" "sep_lifter l\<^sub>3"
    shows "l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>3 = l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t (l\<^sub>2 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>3)"
  proof -
    interpret l1: sep_lifter l\<^sub>1 by fact
    interpret l2: sep_lifter l\<^sub>2 by fact
    interpret l3: sep_lifter l\<^sub>3 by fact

    show ?thesis
      unfolding compose_lifter_def compose_carve_def compose_splittable_def
      by (auto del: ext intro!: ext simp: sep_algebra_simps)

  qed

  lemma lift_assn_compose:
    assumes "sep_lifter l\<^sub>1"
    assumes "sep_lifter l\<^sub>2"
    shows "pre_sep_lifter.lift_assn (l\<^sub>1 \<bullet>\<^sub>l\<^sub>f\<^sub>t l\<^sub>2) P = pre_sep_lifter.lift_assn l\<^sub>2 (pre_sep_lifter.lift_assn l\<^sub>1 P)"
  proof -
    interpret l1: sep_lifter l\<^sub>1 by fact
    interpret l2: sep_lifter l\<^sub>2 by fact

    show ?thesis
      apply (rule ext)
      apply (auto simp: pre_sep_lifter.lift_assn_def)
      apply (auto simp: compose_lifter_def compose_splittable_def compose_carve_def)
      done
  qed

  definition "id_lifter ty \<alpha> \<equiv> \<lparr>
    sep_lifter.lift = id,
    sep_lifter.project = id,
    sep_lifter.carve = \<lambda>x. 0,
    sep_lifter.splittable = (\<lambda>f. True),
    sep_lifter.L = id\<^sub>L,
    sep_lifter.\<alpha>b = \<alpha>,
    sep_lifter.\<alpha>s = \<alpha>,
    sep_lifter.tyb = ty,
    sep_lifter.tys = ty
  \<rparr>"

  lemma id_lifter_simps[simp]:
    "sep_lifter.lift (id_lifter ty \<alpha>) = id"
    "sep_lifter.project (id_lifter ty \<alpha>) = id"
    "sep_lifter.carve (id_lifter ty \<alpha>) = (\<lambda>x. 0)"
    "sep_lifter.splittable (id_lifter ty \<alpha>) = (\<lambda>f. True)"
    "sep_lifter.L (id_lifter ty \<alpha>) = id\<^sub>L"
    "sep_lifter.\<alpha>b (id_lifter ty \<alpha>) = \<alpha>"
    "sep_lifter.\<alpha>s (id_lifter ty \<alpha>) = \<alpha>"
    "sep_lifter.tyb (id_lifter ty \<alpha>) = ty"
    "sep_lifter.tys (id_lifter ty \<alpha>) = ty"
    unfolding id_lifter_def by auto

  lemma id_lifter[simp, intro!]: "sep_lifter (id_lifter ty \<alpha>)"
    apply unfold_locales
    apply (auto simp: id_lifter_def)
    done

  lemma compose_lifter_id_left[simp]:
    assumes "sep_lifter l" shows "id_lifter (sep_lifter.tys l) (sep_lifter.\<alpha>s l) \<bullet>\<^sub>l\<^sub>f\<^sub>t l = l"
  proof -
    interpret sep_lifter l by fact

    have [simp]: "compose_carve (id_lifter (sep_lifter.tys l) (sep_lifter.\<alpha>s l)) l = carve"
      by (rule ext) (auto simp: compose_carve_def compose_splittable_def id_lifter_def)

    show ?thesis
      apply (auto simp: compose_lifter_def)
      apply (auto simp: compose_splittable_def id_lifter_def)
      done
  qed

  lemma compose_lifter_id_right[simp]:
    assumes "sep_lifter l" shows "l \<bullet>\<^sub>l\<^sub>f\<^sub>t (id_lifter (sep_lifter.tyb l) (sep_lifter.\<alpha>b l)) = l"
  proof -
    interpret sep_lifter l by fact

    have [simp]: "compose_carve l (id_lifter (sep_lifter.tyb l) (sep_lifter.\<alpha>b l)) = carve"
      by (rule ext) (auto simp: compose_carve_def compose_splittable_def id_lifter_def)

    show ?thesis
      apply (auto simp: compose_lifter_def)
      apply (auto simp: compose_splittable_def id_lifter_def)
      done

  qed

end


(* Title: Verification Component Based on KAD for Forward Reasoning
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsection\<open>Verification Component for Forward Reasoning\<close>

theory VC_KAD_dual
  imports VC_KAD
begin

context modal_kleene_algebra
begin

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

subsubsection \<open>Basic Strongest Postcondition Calculus\<close>

text \<open>In modal Kleene algebra, strongest postconditions are backward diamond operators. These
are linked with forward boxes aka weakest preconditions by a Galois connection.  This duality has been
implemented in the AFP entry for Kleene algebra with domain and is picked up automatically in
the following proofs.\<close>

lemma r_ad [simp]: "r (ad p) = ad p"
  using a_closure addual.ars_r_def am_d_def domrangefix by auto

lemma bdia_export2: "r p \<cdot> \<langle>x| q = \<langle>x \<cdot> r p| q"
  using ardual.ads_d_def ardual.am2 ardual.fdia_export_2 bdia_def by auto

lemma bdia_seq [simp]: "\<langle>x \<cdot> y| q = \<langle>y| \<langle>x| q"
  by (simp add: ardual.ds.fdia_mult)

lemma bdia_seq_var: "\<langle>x| p \<le> p' \<Longrightarrow> \<langle>y| p' \<le> q \<Longrightarrow> \<langle>x \<cdot> y| p \<le> q"
  by (metis ardual.ds.fd_subdist_1 ardual.ds.fdia_mult dual_order.trans join.sup_absorb2)

lemma bdia_cond_var [simp]: "\<langle>if p then x else y fi| q = \<langle>x| (d p \<cdot> r q) + \<langle>y| (ad p \<cdot> r q)"
  by (metis (no_types, lifting) bdia_export1 a4' a_de_morgan a_de_morgan_var_3 a_subid_aux1' ardual.ds.fdia_add2 dka.dnso1 dka.dsg4 domrange dpdz.dnso1 cond_def join.sup.absorb_iff1 rangedom)

lemma bdia_while: "\<langle>x| (d t \<cdot> r p) \<le> r p  \<Longrightarrow> \<langle>while t do x od| p \<le> r p \<cdot> ad t"
proof -
  assume "\<langle>x| (d t \<cdot> r p) \<le> r p"
  hence "\<langle>d t \<cdot> x| p \<le> r p"
    by (metis bdia_export1 dka.dsg4 domrange rangedom)
  hence "\<langle>(d t \<cdot> x)\<^sup>\<star>| p \<le> r p"
    by (meson ardual.fdemodalisation22 ardual.kat_2_equiv_opp star_sim1)
  hence "r (ad t) \<cdot> \<langle>(d t \<cdot> x)\<^sup>\<star>| p \<le> r p \<cdot> ad t"
    by (metis ardual.dpdz.dsg4 ars_r_def mult_isol r_ad)
  thus ?thesis
    by (metis bdia_export2 while_def r_ad)
qed

lemma bdia_whilei: "r p \<le> r i \<Longrightarrow> r i \<cdot> ad t \<le> r q \<Longrightarrow> \<langle>x| (d t \<cdot> r i) \<le> r i \<Longrightarrow> \<langle>while t inv i do x od| p \<le> r q"
proof -
  assume a1: "r p \<le> r i" and a2: "r i \<cdot> ad t \<le> r q" and "\<langle>x| (d t \<cdot> r i) \<le> r i"
  hence "\<langle>while t inv i do x od| i \<le> r i \<cdot> ad t"
    by (simp add: bdia_while whilei_def)
  hence "\<langle>while t inv i do x od| i \<le> r q"
    using a2 dual_order.trans by blast
  hence "r i \<le> |while t inv i do x od] r q"
    using ars_r_def box_diamond_galois_1 domrange by fastforce
  hence "r p \<le> |while t inv i do x od] r q"
    using a1 dual_order.trans by blast
  thus ?thesis
    using ars_r_def box_diamond_galois_1 domrange by fastforce
qed

lemma bdia_whilei_break: "\<langle>y| p \<le> r i \<Longrightarrow> r i \<cdot> ad t \<le> r q \<Longrightarrow> \<langle>x| (d t \<cdot> r i) \<le> r i \<Longrightarrow> \<langle>y \<cdot> (while t inv i do x od)| p \<le> r q"
  using bdia_whilei ardual.ads_d_def ardual.ds.fdia_mult bdia_def by auto

end

subsubsection \<open>Floyd's Assignment Rule\<close>

lemma bdia_assign [simp]: "rel_antirange_kleene_algebra.bdia (v ::= e) \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<exists>w. s v = e (s(v := w)) \<and> P (s(v:=w))\<rceil>"
  apply (simp add: rel_antirange_kleene_algebra.bdia_def gets_def p2r_def rel_ar_def)
  apply safe
  by (metis fun_upd_apply fun_upd_triv fun_upd_upd, fastforce)

lemma d_p2r [simp]: "rel_antirange_kleene_algebra.ars_r  \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: p2r_def rel_antirange_kleene_algebra.ars_r_def rel_ar_def)

abbreviation fspec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("FPRE _ _ POST _" [64,64,64] 63) where
  "FPRE P X POST Q \<equiv> rel_antirange_kleene_algebra.bdia X \<lceil>P\<rceil> \<subseteq> rel_antirange_kleene_algebra.ars_r \<lceil>Q\<rceil>"

end


(*  Title:      HOL/MicroJava/BV/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Lists of a fixed length.
*)

section \<open> Fixed Length Lists \<close>

theory Listn
imports Err
begin

definition list :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
where
  "list n A = {xs. size xs = n \<and> set xs \<subseteq> A}"

definition le :: "'a ord \<Rightarrow> ('a list)ord"
where
  "le r = list_all2 (\<lambda>x y. x \<sqsubseteq>\<^sub>r y)"

abbreviation
  lesublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubseteq>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubseteq>\<^bsub>r\<^esub>] y == x <=_(Listn.le r) y"

abbreviation
  lesssublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubset>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubset>\<^bsub>r\<^esub>] y == x <_(Listn.le r) y"

(*<*)
notation (ASCII)
  lesublist  ("(_ /[<=_] _)" [50, 0, 51] 50) and
  lesssublist  ("(_ /[<_] _)" [50, 0, 51] 50)

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

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

definition map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where
  "map2 f = (\<lambda>xs ys. map (case_prod f) (zip xs ys))"

abbreviation
  plussublist :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
    ("(_ /[\<squnion>\<^bsub>_\<^esub>] _)" [65, 0, 66] 65) where
  "x [\<squnion>\<^bsub>f\<^esub>] y == x \<squnion>\<^bsub>map2 f\<^esub> y"

(*<*)
notation (ASCII)
  plussublist  ("(_ /[+_] _)" [65, 0, 66] 65)

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

primrec coalesce :: "'a err list \<Rightarrow> 'a list err"
where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"

definition sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl"
where
  "sl n = (\<lambda>(A,r,f). (list n A, le r, map2 f))"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err"
where
  "sup f = (\<lambda>xs ys. if size xs = size ys then coalesce(xs [\<squnion>\<^bsub>f\<^esub>] ys) else Err)"

definition upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl"
where
  "upto_esl m = (\<lambda>(A,r,f). (Union{list n A |n. n \<le> m}, le r, sup f))"

lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys = Listn.le r xs ys"
(*<*) by (simp add: lesub_def) (*>*)

lemma Nil_le_conv [iff]: "([] [\<sqsubseteq>\<^bsub>r\<^esub>] ys) = (ys = [])"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_notle_Nil [iff]: "\<not> x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] []"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_le_Cons [iff]: "x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] y#ys = (x \<sqsubseteq>\<^sub>r y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys)"
(*<*)
by (simp add: lesub_def Listn.le_def)
(*>*)

lemma Cons_less_Conss [simp]:
  "order r \<Longrightarrow>  x#xs [\<sqsubset>\<^sub>r] y#ys = (x \<sqsubset>\<^sub>r y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<or> x = y \<and> xs [\<sqsubset>\<^sub>r] ys)"
(*<*)
apply (unfold lesssub_def)
apply blast
done
(*>*)

lemma list_update_le_cong:
  "\<lbrakk> i<size xs; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; x \<sqsubseteq>\<^sub>r y \<rbrakk> \<Longrightarrow> xs[i:=x] [\<sqsubseteq>\<^bsub>r\<^esub>] ys[i:=y]"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
(*>*)

lemma le_listD: "\<lbrakk> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p \<sqsubseteq>\<^sub>r ys!p"
(*<*)
by (simp add: Listn.le_def lesub_def list_all2_nthD)
(*>*)

lemma le_list_refl: "\<forall>x. x \<sqsubseteq>\<^sub>r x \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs"
(*<*)
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
(*>*)

lemma le_list_trans: "\<lbrakk> order r; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<rbrakk> \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
(*>*)

lemma le_list_antisym: "\<lbrakk> order r; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs \<rbrakk> \<Longrightarrow> xs = ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
(*>*)

lemma order_listI [simp, intro!]: "order r \<Longrightarrow> order(Listn.le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
             dest: order_refl)
done
(*>*)

lemma lesub_list_impl_same_size [simp]: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
(*>*)

lemma lesssub_lengthD: "xs [\<sqsubset>\<^sub>r] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold lesssub_def)
apply auto
done
(*>*)

lemma le_list_appendI: "a [\<sqsubseteq>\<^bsub>r\<^esub>] b \<Longrightarrow> c [\<sqsubseteq>\<^bsub>r\<^esub>] d \<Longrightarrow> a@c [\<sqsubseteq>\<^bsub>r\<^esub>] b@d"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
(*>*)

lemma le_listI:
  assumes "length a = length b"
  assumes "\<And>n. n < length a \<Longrightarrow> a!n \<sqsubseteq>\<^sub>r b!n"
  shows "a [\<sqsubseteq>\<^bsub>r\<^esub>] b"
(*<*)
proof -
  from assms have "list_all2 r a b"
    by (simp add: list_all2_all_nthI lesub_def)
  then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
(*>*)

lemma listI: "\<lbrakk> size xs = n; set xs \<subseteq> A \<rbrakk> \<Longrightarrow> xs \<in> list n A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

(* FIXME: remove simp *)
lemma listE_length [simp]: "xs \<in> list n A \<Longrightarrow> size xs = n"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma less_lengthI: "\<lbrakk> xs \<in> list n A; p < n \<rbrakk> \<Longrightarrow> p < size xs"
(*<*) by simp (*>*)

lemma listE_set [simp]: "xs \<in> list n A \<Longrightarrow> set xs \<subseteq> A"
(*<*)
apply (unfold list_def)
apply blast
done
(*>*)

lemma list_0 [simp]: "list 0 A = {[]}"
(*<*)
apply (unfold list_def)
apply auto
done
(*>*)

lemma in_list_Suc_iff:
  "(xs \<in> list (Suc n) A) = (\<exists>y\<in>A. \<exists>ys \<in> list n A. xs = y#ys)"
(*<*)
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
(*>*)

lemma Cons_in_list_Suc [iff]:
  "(x#xs \<in> list (Suc n) A) = (x\<in>A \<and> xs \<in> list n A)"
(*<*)
apply (simp add: in_list_Suc_iff)
done
(*>*)

lemma list_not_empty:
  "\<exists>a. a\<in>A \<Longrightarrow> \<exists>xs. xs \<in> list n A"
(*<*)
apply (induct "n")
 apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
(*>*)

lemma nth_in [rule_format, simp]:
  "\<forall>i n. size xs = n \<longrightarrow> set xs \<subseteq> A \<longrightarrow> i < n \<longrightarrow> (xs!i) \<in> A"
(*<*)
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma listE_nth_in: "\<lbrakk> xs \<in> list n A; i < n \<rbrakk> \<Longrightarrow> xs!i \<in> A"
(*<*) by auto (*>*)

lemma listn_Cons_Suc [elim!]:
  "l#xs \<in> list n A \<Longrightarrow> (\<And>n'. n = Suc n' \<Longrightarrow> l \<in> A \<Longrightarrow> xs \<in> list n' A \<Longrightarrow> P) \<Longrightarrow> P"
(*<*) by (cases n) auto (*>*)

lemma listn_appendE [elim!]:
  "a@b \<in> list n A \<Longrightarrow> (\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P) \<Longrightarrow> P"
(*<*)
proof -
  have "\<And>n. a@b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n=n1+n2 \<and> a \<in> list n1 A \<and> b \<in> list n2 A"
    (is "\<And>n. ?list a n \<Longrightarrow> \<exists>n1 n2. ?P a n n1 n2")
  proof (induct a)
    fix n assume "?list [] n"
    hence "?P [] n 0 n" by simp
    thus "\<exists>n1 n2. ?P [] n n1 n2" by fast
  next
    fix n l ls
    assume "?list (l#ls) n"
    then obtain n' where n: "n = Suc n'" "l \<in> A" and n': "ls@b \<in> list n' A" by fastforce
    assume "\<And>n. ls @ b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A"
    from this and n' have "\<exists>n1 n2. n' = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A" .
    then obtain n1 n2 where "n' = n1 + n2" "ls \<in> list n1 A" "b \<in> list n2 A" by fast
    with n have "?P (l#ls) n (n1+1) n2" by simp
    thus "\<exists>n1 n2. ?P (l#ls) n n1 n2" by fastforce
  qed
  moreover
  assume "a@b \<in> list n A" "\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P"
  ultimately
  show ?thesis by blast
qed
(*>*)

lemma listt_update_in_list [simp, intro!]:
  "\<lbrakk> xs \<in> list n A; x\<in>A \<rbrakk> \<Longrightarrow> xs[i := x] \<in> list n A"
(*<*)
apply (unfold list_def)
apply simp
done
(*>*)

lemma list_appendI [intro?]:
  "\<lbrakk> a \<in> list n A; b \<in> list m A \<rbrakk> \<Longrightarrow> a @ b \<in> list (n+m) A"
(*<*) by (unfold list_def) auto (*>*)

lemma list_map [simp]: "(map f xs \<in> list (size xs) A) = (f ` set xs \<subseteq> A)"
(*<*) by (unfold list_def) simp (*>*)

lemma list_replicateI [intro]: "x \<in> A \<Longrightarrow> replicate n x \<in> list n A"
(*<*) by (induct n) auto (*>*)

lemma plus_list_Nil [simp]: "[] [\<squnion>\<^bsub>f\<^esub>] xs = []"
(*<*)
apply (unfold plussub_def map2_def)
apply simp
done
(*>*)

lemma plus_list_Cons [simp]:
  "(x#xs) [\<squnion>\<^bsub>f\<^esub>] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x \<squnion>\<^sub>f y)#(xs [\<squnion>\<^bsub>f\<^esub>] ys))"
(*<*) by (simp add: plussub_def map2_def split: list.split) (*>*)

lemma length_plus_list [rule_format, simp]:
  "\<forall>ys. size(xs [\<squnion>\<^bsub>f\<^esub>] ys) = min(size xs) (size ys)"
(*<*)
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
(*>*)

lemma nth_plus_list [rule_format, simp]:
  "\<forall>xs ys i. size xs = n \<longrightarrow> size ys = n \<longrightarrow> i<n \<longrightarrow> (xs [\<squnion>\<^bsub>f\<^esub>] ys)!i = (xs!i) \<squnion>\<^sub>f (ys!i)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
(*>*)

lemma (in Semilat) plus_list_ub1 [rule_format]:
 "\<lbrakk> set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_ub2:
 "\<lbrakk>set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk> \<Longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_lub [rule_format]:
shows "\<forall>xs ys zs. set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> set zs \<subseteq> A
  \<longrightarrow> size xs = n \<and> size ys = n \<longrightarrow>
  xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<longrightarrow> xs [\<squnion>\<^bsub>f\<^esub>] ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) list_update_incr [rule_format]:
 "x\<in>A \<Longrightarrow> set xs \<subseteq> A \<longrightarrow>
  (\<forall>i. i<size xs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs[i := x \<squnion>\<^sub>f xs!i])"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma acc_le_listI [intro!]:
  "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
(*<*)
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le r) ys})")
 apply (erule wf_subset)
 apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
 prefer 2
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
done
(*>*)

lemma closed_listI:
  "closed S f \<Longrightarrow> closed (list n S) (map2 f)"
(*<*)
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
(*>*)

lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
  apply (unfold Listn.sl_def)
  apply (simp (no_asm) only: semilat_Def split_conv)
  apply (rule conjI)
   apply simp
  apply (rule conjI)
   apply (simp only: closedI closed_listI)
  apply (simp (no_asm) only: list_def)
  apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
  done
qed
(*>*)

lemma Listn_sl: "semilat L \<Longrightarrow> semilat (Listn.sl n L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all) (*>*)

lemma coalesce_in_err_list [rule_format]:
  "\<forall>xes. xes \<in> list n (err A) \<longrightarrow> coalesce xes \<in> err(list n A)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
(*>*)

lemma lem: "\<And>x xs. x \<squnion>\<^bsub>(#)\<^esub> xs = x#xs"
(*<*) by (simp add: plussub_def) (*>*)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
(*>*)

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
(*>*)

lemma lift2_le_ub:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A; x \<squnion>\<^sub>f y = OK z;
      u\<in>A; x \<sqsubseteq>\<^sub>r u; y \<sqsubseteq>\<^sub>r u \<rbrakk> \<Longrightarrow> z \<sqsubseteq>\<^sub>r u"
(*<*)
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
(*>*)

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  (\<forall>zs us. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] us \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] us
           \<and> us \<in> list n A \<longrightarrow> zs [\<sqsubseteq>\<^bsub>r\<^esub>] us))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done
(*>*)

lemma lift2_eq_ErrD:
  "\<lbrakk> x \<squnion>\<^sub>f y = Err; semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A \<rbrakk>
  \<Longrightarrow> \<not>(\<exists>u\<in>A. x \<sqsubseteq>\<^sub>r u \<and> y \<sqsubseteq>\<^sub>r u)"
(*<*) by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1]) (*>*)

lemma coalesce_eq_Err_D [rule_format]:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
  \<Longrightarrow> \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
      coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = Err \<longrightarrow>
      \<not>(\<exists>zs \<in> list n A. xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done
(*>*)

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> err A)"
(*<*)
apply (unfold closed_def)
apply (simp add: err_def')
done
(*>*)

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>ys. ys \<in> list n A \<longrightarrow>
  map2 f xs ys \<in> list n (err A))"
(*<*)
apply (unfold map2_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
(*>*)

lemma err_semilat_sup:
  "err_semilat (A,r,f) \<Longrightarrow>
  err_semilat (list n A, Listn.le r, sup f)"
(*<*)
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
(*>*)

lemma err_semilat_upto_esl:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
(*<*)
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done
(*>*)

end


(*<*)(*:maxLineLen=68:*)
theory ndAutomaton
  imports bundle.SB_fin (* dAutomaton *)
begin
default_sort "chan"

(*>*)

subsection \<open>Non-Deterministic Automaton\<close> text\<open>\label{sub:ndaut}\<close>

text\<open>Non-deterministic automatons can model behaviours of
incomplete systems or components since their behaviour could be
arbitrary, we cannot use automatons with a deterministic transition
function. Thus, the non-deterministic automatons transition function
maps to a set that represents all possible behaviours of the system.
Furthermore, we also might have different combinations of initial
states and outputs for a under-specified system, hence we define the
initial configuration of a non-deterministic automaton as a set of
tuples, where each tuple represents an initial state and an initial
output. Deterministic automatons are a special case of
non-deterministic automatons where the transition function maps to a
singleton and the initial configuration is also a singleton.\<close>

text\<open>This first interpretation of non-deterministic automatons
allows the initial configuration or the output of the transition
function to be empty. We define these as incomplete automatons.\<close>

record ('state::type,'in, 'out)
ndAutomaton_incomplete  =
  ndaiTransition :: "('state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> (('state \<times> 'out\<^sup>\<Omega>) set))"
  ndaiInitConfig :: "('state \<times> 'out\<^sup>\<Omega>) set"

text\<open>A complete automaton has a defined behaviour in all cases. One
can complete the automatons with incomplete behaviour using
different approaches. The Chaos approach, where the automaton
behaves completely arbitrary, will be presented after instantiating
complete non-deterministic automatons as a \gls{cpo}.\<close>

cpodef ('state::type,'in,'out)ndAutomaton  =
  "{(transition::(('state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> (('state \<times> 'out\<^sup>\<Omega>) set)))
    , initialConfig::('state \<times> 'out\<^sup>\<Omega>) set)
    | transition initialConfig.
      (\<forall>state sbe. transition state sbe \<noteq> {})
    \<and> initialConfig \<noteq> {}}"
  apply auto[1]
  apply (subst UU_eq_empty[symmetric])+
  apply (rule admI)
  apply (simp add: lub_prod)
  apply (rule, rule, rule)
  apply (simp_all add: lub_eq_bottom_iff mem_Times_iff)
proof -
  fix Y :: "nat \<Rightarrow>
  ('state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> ('state \<times> 'out\<^sup>\<Omega>) set) \<times> ('state \<times> 'out\<^sup>\<Omega>) set"
  and state :: 'state and sbe :: "'in\<^sup>\<surd>"
  assume a1: "\<forall>i. (\<forall>state sbe. fst (Y i) state sbe \<noteq> \<bottom>) \<and>
                               snd (Y i)           \<noteq> \<bottom>"
  assume "chain Y"
  then have "chain (\<lambda>n. fst (Y n))"
    using ch2ch_fst by blast
  then show "(\<Squnion>n. fst (Y n)) state sbe \<noteq> \<bottom>"
    using a1 by (simp add: fun_chain_iff lub_eq_bottom_iff lub_fun)
qed

setup_lifting type_definition_ndAutomaton

text\<open>The chaos completion is realized using the universal set \<open>UNIV\<close>
that contains all possible elements. If the initial configuration is
empty, it is replaced by \<open>UNIV\<close>. If the transition function of the
incomplete automaton would map to the empty set, it will instead map
to \<open>UNIV\<close>. Thus, the resulting automaton is completed by the chaos
completion.\<close>

lift_definition ndai2ndac::
"('state::type,'in, 'out) ndAutomaton_incomplete
\<Rightarrow>('state::type,'in, 'out) ndAutomaton " is
"\<lambda>auti. ((\<lambda> s sbe. let out = ndaiTransition auti s sbe in
                   if out = {} then UNIV else out),
                   if ndaiInitConfig auti = {}
                               then UNIV else ndaiInitConfig auti)"
  apply auto
  by (metis (mono_tags) empty_not_UNIV)

text\<open>For obtaining the transitions function or the initial
configuration two getters are defined.\<close>

definition ndaTransition::
"('state::type, 'in, 'out) ndAutomaton \<rightarrow>
('state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> ('state \<times> 'out\<^sup>\<Omega>) set)" where
"ndaTransition = (\<Lambda> aut. fst(Rep_ndAutomaton aut))"

definition ndaInitConfig::
"('state::type, 'in, 'out) ndAutomaton \<rightarrow>
('state \<times>'out\<^sup>\<Omega>)set" where
"ndaInitConfig = (\<Lambda> aut. (snd(Rep_ndAutomaton aut)))"

subsubsection\<open>Semantic\<close>

text\<open>The semantic of a non-deterministic automaton can not be
described by a single \gls{spf} because it would have a
deterministic behaviour. Instead, the semantic is a \gls{sps} where
each \gls{spf} describes a possible behaviour of the automaton.\<close>

lemma ndastatesem_mono[simp]:"mono (\<lambda>h state. {sb_split\<cdot>(\<lambda>sbe. \<Lambda> sb.
    (let (nextSPF, output) = f' sbe in
                            output \<bullet>\<^sup>\<Omega> nextSPF\<cdot>sb))

  | f f'.  \<forall>sbe . ((f sbe) \<in> (((ndaTransition\<cdot>nda) state) sbe))
        \<and> ( \<forall>sbe . snd (f' sbe) = snd (f sbe) \<and>
                   fst (f' sbe) \<in> h (fst (f sbe)))})"
  apply(rule monoI)
  apply(simp add: prod.case_eq_if)
  apply(simp add: le_fun_def)
  apply auto
  apply(rule_tac x="f"in exI)
  apply(rule_tac x="f'" in exI)
  by auto

text\<open>Similar to the deterministic semantic mappings we define a
non-deterministic state semantic mapping and then use it to define
the semantic mapping of an automaton. The semantic mapping is
defined greatest fixed point to characterize the greatest
possible behaviour of a component.\<close>

definition ndaStateSem ::
 "('s::type, 'in::{chan, finite}, 'out) ndAutomaton
\<Rightarrow> ('s \<Rightarrow> ('in\<^sup>\<Omega> \<rightarrow> 'out\<^sup>\<Omega>) set)" where
"ndaStateSem nda \<equiv> gfp (\<lambda>h state. {sb_split\<cdot>(\<lambda> sbe. \<Lambda> sb.
    (let (nextSPF, output) = f' sbe in
                            output \<bullet>\<^sup>\<Omega> nextSPF\<cdot>sb))

  | f f'.  \<forall>sbe . ((f sbe) \<in> (((ndaTransition\<cdot>nda) state) sbe))
        \<and> ( \<forall>sbe . snd (f' sbe) = snd (f sbe) \<and>
                   fst (f' sbe) \<in> h (fst (f sbe)))})"
    (* TODO: Schöner! *)

text\<open>All resulting \glspl{spf} in the semantic iterate over the
input and then decide in each step depending on the current state of
the automaton how to process its input. The output is then an
element of the output from the transition function. Hence, it is
possible for a \gls{spf} to produce different output, even if the
state and input of the automaton did not change. This represents the
non-determinism of the component.\<close>

lemma ndastatesem_unfold:"ndaStateSem nda s = {sb_split\<cdot>(\<lambda> sbe.
\<Lambda> sb. let (nextSPF, output) = f' sbe in output \<bullet>\<^sup>\<Omega> nextSPF\<cdot>sb)|
     f f' .(\<forall>sbe. f sbe \<in> (ndaTransition\<cdot>nda) s sbe \<and>
            (\<forall>sbe. snd (f' sbe) = snd (f sbe) \<and>
                   fst (f' sbe) \<in> ndaStateSem nda (fst (f sbe))))}"
  unfolding ndaStateSem_def
  apply(subst gfp_unfold)
  using ndastatesem_mono apply auto[1]
  by auto

text\<open>Since there can be more than one initial configuration the
semantic contains \glspl{spf} representing each initial
configuration.\<close>

definition ndaSem ::
"('s::type, 'in::{chan, finite}, 'out) ndAutomaton
\<Rightarrow> ('in\<^sup>\<Omega> \<rightarrow> 'out\<^sup>\<Omega>) set" where
"ndaSem  nda \<equiv> {(\<Lambda> sb. initOut \<bullet>\<^sup>\<Omega> spf\<cdot>sb) | initOut initState spf.
    (initState,initOut)\<in>ndaInitConfig\<cdot>nda \<and>
                    spf\<in>(ndaStateSem nda initState)}"

(*<*)
end
(*>*)


(*  Author:     Tobias Nipkow, 2007  *)

header{* Presburger arithmetic *}

theory PresArith
imports GCD QE "~~/src/HOL/Library/ListVector"
begin

declare iprod_assoc[simp]

subsection{*Syntax*}

datatype atom =
  Le int "int list" | Dvd int int "int list" | NDvd int int "int list"

fun divisor :: "atom \<Rightarrow> int" where
"divisor (Le i ks) = 1" |
"divisor (Dvd d i ks) = d" |
"divisor (NDvd d i ks) = d"

fun neg\<^sub>Z :: "atom \<Rightarrow> atom fm" where
"neg\<^sub>Z (Le i ks) = Atom(Le (1-i) (-ks))" |
"neg\<^sub>Z (Dvd d i ks) = Atom(NDvd d i ks)" |
"neg\<^sub>Z (NDvd d i ks) = Atom(Dvd d i ks)"

fun hd_coeff :: "atom \<Rightarrow> int" where
"hd_coeff (Le i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)" |
"hd_coeff (Dvd d i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)" |
"hd_coeff (NDvd d i ks) = (case ks of [] \<Rightarrow> 0 | k#_ \<Rightarrow> k)"

fun decr\<^sub>Z :: "atom \<Rightarrow> atom" where
"decr\<^sub>Z (Le i ks) = Le i (tl ks)" |
"decr\<^sub>Z (Dvd d i ks) = Dvd d i (tl ks)" |
"decr\<^sub>Z (NDvd d i ks) = NDvd d i (tl ks)"

fun I\<^sub>Z :: "atom \<Rightarrow> int list \<Rightarrow> bool" where
"I\<^sub>Z (Le i ks) xs = (i \<le> \<langle>ks,xs\<rangle>)" |
"I\<^sub>Z (Dvd d i ks) xs = (d dvd i+\<langle>ks,xs\<rangle>)" |
"I\<^sub>Z (NDvd d i ks) xs = (\<not> d dvd i+\<langle>ks,xs\<rangle>)"

definition "atoms\<^sub>0 = ATOM.atoms\<^sub>0 (\<lambda>a. hd_coeff a \<noteq> 0)"
(* FIXME !!! (incl: display should hide params)*)

interpretation Z!:
  ATOM neg\<^sub>Z "(\<lambda>a. divisor a \<noteq> 0)" I\<^sub>Z "(\<lambda>a. hd_coeff a \<noteq> 0)" decr\<^sub>Z
  where "ATOM.atoms\<^sub>0 (\<lambda>a. hd_coeff a \<noteq> 0) = atoms\<^sub>0"
proof-
  case goal1
  thus ?case
apply(unfold_locales)
apply(case_tac a)
apply simp_all
apply(case_tac a)
apply simp_all
apply(case_tac a)
apply (simp_all)
apply arith
apply(case_tac a)
apply(simp_all add: split: list.splits)
apply(case_tac a)
apply simp_all
done
next
  case goal2 thus ?case by(simp add:atoms\<^sub>0_def)
qed

setup {* Sign.revert_abbrev "" @{const_abbrev Z.I} *}
setup {* Sign.revert_abbrev "" @{const_abbrev Z.lift_dnf_qe} *}
(* FIXME doesn't work*)
(* FIXME does not help
setup {* Sign.revert_abbrev "" @{const_abbrev Z.normal} *}
*)

abbreviation
"hd_coeff_is1 a \<equiv>
  (case a of Le _ _ \<Rightarrow> hd_coeff a : {1,-1} | _ \<Rightarrow> hd_coeff a = 1)"

fun asubst :: "int \<Rightarrow> int list \<Rightarrow> atom \<Rightarrow> atom" where
"asubst i' ks' (Le i (k#ks)) = Le (i - k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' (Dvd d i (k#ks)) = Dvd d (i + k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' (NDvd d i (k#ks)) = NDvd d (i + k*i') (k *\<^sub>s ks' + ks)" |
"asubst i' ks' a = a"

abbreviation subst :: "int \<Rightarrow> int list \<Rightarrow> atom fm \<Rightarrow> atom fm"
where "subst i ks \<equiv> map\<^bsub>fm\<^esub> (asubst i ks)"

lemma IZ_asubst: "I\<^sub>Z (asubst i ks a) xs = I\<^sub>Z a ((i + \<langle>ks,xs\<rangle>) # xs)"
apply (cases a)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
apply (rename_tac list)
apply (case_tac list)
apply (simp_all add:algebra_simps iprod_left_add_distrib)
done

lemma I_subst:
  "qfree \<phi> \<Longrightarrow> Z.I \<phi> ((i + \<langle>ks,xs\<rangle>) # xs) = Z.I (subst i ks \<phi>) xs"
by (induct \<phi>) (simp_all add:IZ_asubst)

lemma divisor_asubst[simp]: "divisor (asubst i ks a) = divisor a"
by(induct i ks a rule:asubst.induct) auto

definition "lbounds as = [(i,ks). Le i (k#ks) \<leftarrow> as, k>0]"
definition "ubounds as = [(i,ks). Le i (k#ks) \<leftarrow> as, k<0]"
lemma set_lbounds:
  "set(lbounds as) = {(i,ks)|i k ks. Le i (k#ks) : set as \<and> k>0}"
by(auto simp: lbounds_def split:list.splits atom.splits if_splits)
lemma set_ubounds:
  "set(ubounds as) = {(i,ks)|i k ks. Le i (k#ks) : set as \<and> k<0}"
by(auto simp: ubounds_def split:list.splits atom.splits if_splits)

lemma lbounds_append[simp]: "lbounds(as @ bs) = lbounds as @ lbounds bs"
by(simp add:lbounds_def)

subsection{*LCM and lemmas*}

fun zlcms :: "int list \<Rightarrow> int" where
"zlcms [] = 1" |
"zlcms (i#is) = lcm i (zlcms is)"

lemma dvd_zlcms: "i : set is \<Longrightarrow> i dvd zlcms is"
by(induct "is") auto

lemma zlcms_pos: "\<forall>i \<in> set is. i\<noteq>0 \<Longrightarrow> zlcms is > 0"
by(induct "is")(auto simp:lcm_pos_int)

lemma zlcms0_iff[simp]: "(zlcms is = 0) = (0 : set is)"
by (metis mod_by_0 dvd_eq_mod_eq_0 dvd_zlcms zlcms_pos less_le)

lemma elem_le_zlcms: "\<forall>i \<in> set is. i \<noteq> 0 \<Longrightarrow> i : set is \<Longrightarrow> i \<le> zlcms is"
by (metis dvd_zlcms zdvd_imp_le zlcms_pos)

subsection{* Setting coeffiencients to 1 or -1 *}

fun hd_coeff1 :: "int \<Rightarrow> atom \<Rightarrow> atom" where
"hd_coeff1 m (Le i (k#ks)) =
   (if k=0 then Le i (k#ks)
    else let m' = m div (abs k) in Le (m'*i) (sgn k # (m' *\<^sub>s ks)))" |
"hd_coeff1 m (Dvd d i (k#ks)) =
   (if k=0 then Dvd d i (k#ks)
    else let m' = m div k in Dvd (m'*d) (m'*i) (1 # (m' *\<^sub>s ks)))" |
"hd_coeff1 m (NDvd d i (k#ks)) =
   (if k=0 then NDvd d i (k#ks)
    else let m' = m div k in NDvd (m'*d) (m'*i) (1 # (m' *\<^sub>s ks)))" |
"hd_coeff1 _ a = a"

text{* The def of @{const hd_coeff1} on @{const Dvd} and @{const NDvd} is
different from the @{const Le} because it allows the resulting head
coefficient to be 1 rather than 1 or -1. We show that the other version has
the same semantics: *}

lemma "\<lbrakk> k \<noteq> 0; k dvd m \<rbrakk> \<Longrightarrow>
  I\<^sub>Z (hd_coeff1 m (Dvd d i (k#ks))) (x#e) = (let m' = m div (abs k) in
  I\<^sub>Z (Dvd (m'*d) (m'*i) (sgn k # (m' *\<^sub>s ks))) (x#e))"
apply(auto simp:algebra_simps abs_if sgn_if)
 apply(simp add: zdiv_zminus2_eq_if dvd_eq_mod_eq_0[THEN iffD1] algebra_simps)
 apply (metis diff_conv_add_uminus add.left_commute dvd_minus_iff minus_add_distrib)
apply(simp add: zdiv_zminus2_eq_if dvd_eq_mod_eq_0[THEN iffD1] algebra_simps)
apply (metis diff_conv_add_uminus add.left_commute dvd_minus_iff minus_add_distrib)
done

lemma I_hd_coeff1_mult_a: assumes "m>0"
shows "hd_coeff a dvd m | hd_coeff a = 0 \<Longrightarrow> I\<^sub>Z (hd_coeff1 m a) (m*x#xs) = I\<^sub>Z a (x#xs)"
proof(induct a)
  case (Le i ks)[simp]
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons k ks')[simp]
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with Le have "\<bar>k\<bar> dvd m" by simp
      let ?m' = "m div \<bar>k\<bar>"
      have "?m' > 0" using `\<bar>k\<bar> dvd m` pos_imp_zdiv_pos_iff `m>0` `k\<noteq>0`
        by(simp add:zdvd_imp_le)
      have 1: "k*(x*?m') = sgn k * x * m"
      proof -
        have "k*(x*?m') = (sgn k * abs k) * (x * ?m')"
          by(simp only: mult_sgn_abs)
        also have "\<dots> = sgn k * x * (abs k * ?m')" by simp
        also have "\<dots> = sgn k * x * m"
          using dvd_mult_div_cancel[OF `\<bar>k\<bar> dvd m`] by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (Le i ks)) (m*x#xs) \<longleftrightarrow>
            (i*?m' \<le> sgn k * m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using `k\<noteq>0` by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> ?m'*i \<le> ?m' * (k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> i \<le> k*x + \<langle>ks',xs\<rangle>" using `?m'>0`
        by simp
      finally show ?thesis by(simp)
    qed
  qed
next
  case (Dvd d i ks)[simp]
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons k ks')[simp]
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with Dvd have "k dvd m" by simp
      let ?m' = "m div k"
      have "?m' \<noteq> 0" using `k dvd m` zdiv_eq_0_iff `m>0` `k\<noteq>0`
        by(simp add:linorder_not_less zdvd_imp_le)
      have 1: "k*(x*?m') = x * m"
      proof -
        have "k*(x*?m') = x*(k*?m')" by(simp add:algebra_simps)
        also have "\<dots> = x*m" using dvd_mult_div_cancel[OF `k dvd m`]
          by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (Dvd d i ks)) (m*x#xs) \<longleftrightarrow>
            (?m'*d dvd ?m'*i + m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using `k\<noteq>0` by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> ?m'*d dvd ?m' * (i + k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> d dvd i + k*x + \<langle>ks',xs\<rangle>" using `?m'\<noteq>0` by(simp)
      finally show ?thesis by(simp add:algebra_simps)
    qed
  qed
next
  case (NDvd d i ks)[simp]
  show ?case
  proof(cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons k ks')[simp]
    show ?thesis
    proof cases
      assume "k=0" thus ?thesis by simp
    next
      assume "k\<noteq>0"
      with NDvd have "k dvd m" by simp
      let ?m' = "m div k"
      have "?m' \<noteq> 0" using `k dvd m` zdiv_eq_0_iff `m>0` `k\<noteq>0`
        by(simp add:linorder_not_less zdvd_imp_le)
      have 1: "k*(x*?m') = x * m"
      proof -
        have "k*(x*?m') = x*(k*?m')" by(simp add:algebra_simps)
        also have "\<dots> = x*m" using dvd_mult_div_cancel[OF `k dvd m`]
          by(simp add:algebra_simps)
        finally show ?thesis .
      qed
      have "I\<^sub>Z (hd_coeff1 m (NDvd d i ks)) (m*x#xs) \<longleftrightarrow>
            \<not>(?m'*d dvd ?m'*i + m*x + ?m' * \<langle>ks',xs\<rangle>)"
        using `k\<noteq>0` by(simp add: algebra_simps)
      also have "\<dots> \<longleftrightarrow> \<not> ?m'*d dvd ?m' * (i + k*x + \<langle>ks',xs\<rangle>)" using 1
        by(simp (no_asm_simp) add:algebra_simps)
      also have "\<dots> \<longleftrightarrow> \<not> d dvd i + k*x + \<langle>ks',xs\<rangle>" using `?m'\<noteq>0` by(simp)
      finally show ?thesis by(simp add:algebra_simps)
    qed
  qed
qed

lemma I_hd_coeff1_mult: assumes "m>0"
shows "qfree \<phi> \<Longrightarrow> \<forall> a \<in> set(Z.atoms\<^sub>0 \<phi>). hd_coeff a dvd m \<Longrightarrow>
 Z.I (map\<^bsub>fm\<^esub> (hd_coeff1 m) \<phi>) (m*x#xs) = Z.I \<phi> (x#xs)"
proof(induct \<phi>)
  case (Atom a)
  thus ?case using I_hd_coeff1_mult_a[OF `m>0`] by auto
qed simp_all

end


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

section \<open>Classes cpo and pcpo\<close>

theory Pcpo
imports Porder
begin

subsection \<open>Complete partial orders\<close>

text \<open>The class cpo of chain complete partial orders\<close>

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

text \<open>in cpo's everthing equal to THE lub has lub properties for every chain\<close>

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

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

text \<open>Properties of the lub\<close>

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

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

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

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

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

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

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

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

text \<open>the \<open>\<sqsubseteq>\<close> relation between two chains is preserved by their lubs\<close>

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

text \<open>the = relation between two chains is preserved by their lubs\<close>

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

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

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

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

end

subsection \<open>Pointed cpos\<close>

text \<open>The class pcpo of pointed cpos\<close>

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

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

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

end

text \<open>Old "UU" syntax:\<close>

syntax UU :: logic

translations "UU" => "CONST bottom"

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

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

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

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

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

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

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

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

subsection \<open>Chain-finite and flat cpos\<close>

text \<open>further useful classes for HOLCF domains\<close>

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

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

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

end

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

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

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

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

end

subsection \<open>Discrete cpos\<close>

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

subclass po
proof qed simp_all

text \<open>In a discrete cpo, every chain is constant\<close>

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

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

end

end


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

section\<open>Examples of execution using symbolic computation and iarrays\<close>

theory Examples_QR_IArrays_Symbolic
imports
  Examples_QR_Abstract_Symbolic
  QR_Decomposition_IArrays
begin

subsection\<open>Execution of the QR decomposition using symbolic computation and iarrays\<close>

definition "show_vec_real_iarrays v = IArray.of_fun (\<lambda>i. show_real (v !! i)) (IArray.length v)"

lemma vec_to_iarray_show_vec_real[code_unfold]: "vec_to_iarray (show_vec_real v)
  = show_vec_real_iarrays (vec_to_iarray v)"
  unfolding show_vec_real_def show_vec_real_iarrays_def vec_to_iarray_def by auto

text\<open>The following function is used to print elements of type vec as lists of characters;
  useful for printing vectors in the output panel.\<close>

definition "print_vec = IArray.list_of \<circ> show_vec_real_iarrays \<circ> vec_to_iarray"

definition "show_matrix_real_iarrays A = IArray.of_fun (\<lambda>i. show_vec_real_iarrays (A !! i)) (IArray.length A)"

lemma matrix_to_iarray_show_matrix_real[code_unfold]: "matrix_to_iarray (show_matrix_real v)
  = show_matrix_real_iarrays (matrix_to_iarray v)"
  unfolding show_matrix_real_iarrays_def show_matrix_real_def
  unfolding matrix_to_iarray_def
  by (simp add: vec_to_iarray_show_vec_real)

text\<open>The following functions are useful to print matrices as lists of lists of characters;
  useful for printing in the output panel.\<close>

definition "print_vec_mat = IArray.list_of \<circ> show_vec_real_iarrays"

definition "print_mat_aux A = IArray.of_fun (\<lambda>i. print_vec_mat (A !! i)) (IArray.length A)"

definition "print_mat = IArray.list_of \<circ> print_mat_aux \<circ> matrix_to_iarray"

subsubsection\<open>Examples\<close>

value "let A = list_of_list_to_matrix [[1,2,4],[9,4,5],[0,0,0]]::real^3^3 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray (show_matrix_real (divide_by_norm A)))"

value "let A = list_of_list_to_matrix [[1,2,4],[9,4,5],[0,0,4]]::real^3^3 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray (show_matrix_real (fst (QR_decomposition A))))"

value "let A = list_of_list_to_matrix [[1,2,4],[9,4,5],[0,0,4]]::real^3^3 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray (show_matrix_real (snd (QR_decomposition A))))"

value "let A = list_of_list_to_matrix [[1,2,4],[9,4,5],[0,0,4]]::real^3^3 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray
    (show_matrix_real ((fst (QR_decomposition A)) ** (snd (QR_decomposition A)))))"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4 in rank A = ncols A"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4 in
  print_result_solve (solve A b)"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4
  in
  vec_to_list (show_vec_real (the (inverse_matrix (snd (QR_decomposition A))) ** transpose (fst (QR_decomposition A)) *v b))"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4
  in matrix_to_list_of_list (show_matrix_real ((snd (QR_decomposition A))))"

text\<open>least squares solution\<close>

definition "A \<equiv> list_of_list_to_matrix [[1,3/5,3],[9,4,5/3],[0,0,4],[1,2,3]]::real^3^4"
definition "b \<equiv> list_to_vec [1,2,3,4]::real^4"

value "let Q = fst (QR_decomposition A); R = snd (QR_decomposition A)
  in print_vec ((the (inverse_matrix R) ** transpose Q *v b))"

text\<open>A times least squares solution\<close>

value "let Q = fst (QR_decomposition A); R = snd (QR_decomposition A)
  in print_vec (A *v (the (inverse_matrix R) ** transpose Q *v b))"

text\<open>The matrix Q\<close>

value "print_mat (fst (QR_decomposition A))"

text\<open>The matrix R\<close>

value "print_mat (snd (QR_decomposition A))"

text\<open>The inverse of matrix R\<close>

value "let R = snd (QR_decomposition A) in print_mat (the (inverse_matrix R))"

text\<open>The least squares solution is in the left null space of A\<close>

value "let Q = fst (QR_decomposition A); R = snd (QR_decomposition A);
           b2 = (A *v (the (inverse_matrix R) ** transpose Q *v b))
       in print_vec ((b - b2)v* A)"

value "let A = list_of_list_to_matrix [[1,2,4],[9,4,5],[0,0,4],[3,5,4]]::real^3^4 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray
    (show_matrix_real ((fst (QR_decomposition A)) ** (snd (QR_decomposition A)))))"

value "let A = IArray[IArray[1,2,4],IArray[9,4,5::real],IArray[0,0,0]] in
   iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays (divide_by_norm_iarray A))"

value "let A = IArray[IArray[1,2,4],IArray[9,4,5],IArray[0,0,4]] in
  iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays (fst (QR_decomposition_iarrays A)))"

value "let A = IArray[IArray[1,2,4],IArray[9,4,5],IArray[0,0,4]] in
  iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays (snd (QR_decomposition_iarrays A)))"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4 in rank A = ncols A"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4 in
  print_result_solve (solve A b)"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4
  in
  vec_to_list (show_vec_real (the (inverse_matrix (snd (QR_decomposition A))) ** transpose (fst (QR_decomposition A)) *v b))"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4
  in matrix_to_list_of_list (show_matrix_real ((snd (QR_decomposition A))))"

value "let A = list_of_list_to_matrix [[1,2,3],[9,4,5],[0,0,4],[1,2,3]]::real^3^4;
  b = list_to_vec [1,2,3,4]::real^4;
  b2 = (A *v (the (inverse_matrix (snd (QR_decomposition A))) ** transpose (fst (QR_decomposition A)) *v b))
  in
  vec_to_list (show_vec_real ((b - b2)v* A))"

value "let A = IArray[IArray[1,2,4],IArray[9,4,5],IArray[0,0,4]] in
  iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays
    ((fst (QR_decomposition_iarrays A)) **i (snd (QR_decomposition_iarrays A))))"

value "let A = IArray[IArray[1,2,4],IArray[9,4,5],IArray[0,0,4],IArray[3,5,4]]in
  iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays
    ((fst (QR_decomposition_iarrays A)) **i (snd (QR_decomposition_iarrays A))))"

text\<open>The following example is presented in Chapter 1 of the book
\<open>Numerical Methods in Scientific Computing\<close> by Dahlquist and Bjorck\<close>

value "let A = list_of_list_to_matrix
  [[1,-0.6691],[1,-0.3907],[1,-0.1219],[1,0.3090],[1,0.5878]]::real^2^5;
  b = list_to_vec [0.3704,0.5,0.6211,0.8333,0.9804]::real^5;
  QR = (QR_decomposition A);
  Q = fst QR;
  R = snd QR
  in print_vec (the (inverse_matrix R) ** transpose Q *v b)"

(*
  Limitation: if the input matrix has irrational numbers, then we won't be working in the same
  field extension so the computation will fail.
*)

(*
value[code] "let A = list_of_list_to_matrix [[1,sqrt 2,4],[sqrt 5,4,5],[0,sqrt 7,4]]::real^3^3 in
  iarray_of_iarray_to_list_of_list (matrix_to_iarray (show_matrix_real ((fst (QR_decomposition A)))))"
*)

definition "example = (let A = IArray[IArray[1,2,4],IArray[9,4,5],IArray[0,0,4],IArray[3,5,4]]in
  iarray_of_iarray_to_list_of_list (show_matrix_real_iarrays
    ((fst (QR_decomposition_iarrays A)) **i (snd (QR_decomposition_iarrays A)))))"

export_code example in SML module_name QR

end