(*
  Title: State Transformers and Predicate Transformers Based on the Powerset Monad
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>State Transformers and Predicate Transformers Based on the Powerset Monad\<close>

theory Kleisli_Transformers

imports Powerset_Monad
        Sup_Inf_Preserving_Transformers
begin

subsection \<open>Backward Diamonds from Kleisli Arrows\<close>

text \<open>First I verify the embedding of the Kleisli category of the powerset functor into its Eilenberg-Moore category.
This functor maps sets to their mus and functions to their Kleisli liftings. But this is just functoriality of dagger!.
I model it as a backward diamond operator in the sense of dynamic logic. It corresponds to a strongest postcondition
operator. In the parlance of program semantics, this is an embedding of state into prediate transformers.\<close>

notation klift ("bd\<^sub>\<F>")

text \<open>bd stands for backward diamond, the index indicates the setting of Kleisli arrows or nondeterministic
functions. ifbd is its inverse.\<close>

abbreviation ifbd :: "('a set \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("bd\<^sup>-\<^sub>\<F>") where
  "bd\<^sup>-\<^sub>\<F> \<equiv> (\<lambda>\<phi>. \<phi> \<circ> \<eta>)"

lemma fbd_set: "bd\<^sub>\<F> f X = {y. \<exists>x. y \<in> f x \<and> x \<in> X}"
  by (force simp: klift_prop)

lemma ifbd_set: "bd\<^sup>-\<^sub>\<F> \<phi> x = {y. y \<in> \<phi> {x}}"
  by simp

text \<open>The two functors form a bijective pair.\<close>

lemma fbd_ifbd_inv2: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi>"
proof -
  assume h: "Sup_pres \<phi>"
  have "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = Sup \<circ> \<P> (\<phi> \<circ> \<eta>)"
    unfolding klift_def by simp
  also have "... = Sup \<circ> \<P> \<phi> \<circ> \<P> \<eta>"
    by (simp add: comp_assoc P_func1)
  also have "... = \<phi> \<circ> Sup \<circ> \<P> \<eta>"
    by (simp add: h)
  also have "... = \<phi> \<circ> id"
    by force
  finally show ?thesis
    by simp
qed

lemma fbd_ifbd_inv2_inv: "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi> \<Longrightarrow> Sup_pres \<phi>"
  unfolding fun_eq_iff comp_def by (metis (no_types, lifting) Inf.INF_cong UN_extend_simps(8) klift_prop)

lemma fbd_ifbd_inv2_iff: "((bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = \<phi>) = (Sup_pres \<phi>)"
  using fbd_ifbd_inv2 fbd_ifbd_inv2_inv by force

lemma fbd_inj: "inj bd\<^sub>\<F>"
  by (meson inj_on_inverseI klift_eta_inv1)

lemma fbd_inj_iff: "(bd\<^sub>\<F> f = bd\<^sub>\<F> g) = (f = g)"
  by (meson injD fbd_inj)

lemma ifbd_inj: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi> \<Longrightarrow> \<phi> = \<psi>"
proof-
  assume h1: "Sup_pres \<phi>"
  and h2: "Sup_pres \<psi>"
  and "bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi>"
  hence "(bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<phi> = (bd\<^sub>\<F> \<circ> bd\<^sup>-\<^sub>\<F>) \<psi>"
    by simp
  thus ?thesis
    by (metis h1 h2 fbd_ifbd_inv2)
qed

lemma ifbd_inj_iff: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<F> \<phi> = bd\<^sup>-\<^sub>\<F> \<psi>) = (\<phi> = \<psi>)"
  using ifbd_inj by force

lemma fbd_ifbd_galois: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<F> \<phi> = f) = (bd\<^sub>\<F> f = \<phi>)"
  using fbd_ifbd_inv2 by force

lemma fbd_surj: "Sup_pres \<phi> \<Longrightarrow> (\<exists>f. bd\<^sub>\<F> f = \<phi>)"
  using fbd_ifbd_inv2 by auto

lemma ifbd_surj: "surj bd\<^sup>-\<^sub>\<F>"
  unfolding surj_def by (metis klift_eta_inv1)

text \<open>In addition they preserve the Sup-quantale structure of the powerset algebra. This means that
morphisms preserve compositions, units and Sups, but not Infs, hence also bottom but not top.\<close>

lemma fbd_comp_pres: "bd\<^sub>\<F> (f \<circ>\<^sub>K g) = bd\<^sub>\<F> g \<circ> bd\<^sub>\<F> f"
  unfolding kcomp_klift klift_prop1 by simp

lemma fbd_Sup_pres: "Sup_pres bd\<^sub>\<F>"
  by (force simp: fun_eq_iff klift_def)

lemma fbd_sup_pres: "sup_pres bd\<^sub>\<F>"
  using Sup_sup_pres fbd_Sup_pres by blast

lemma fbd_Disj: "Sup_pres (bd\<^sub>\<F> f)"
  by (simp add: fbd_ifbd_inv2_inv)

lemma fbd_disj: "sup_pres (bd\<^sub>\<F> f)"
  by (simp add: klift_prop)

lemma fbd_bot_pres: "bot_pres bd\<^sub>\<F>"
  unfolding klift_def by fastforce

lemma fbd_iso: "X \<subseteq> Y \<longrightarrow> bd\<^sub>\<F> f X \<subseteq> bd\<^sub>\<F> f Y"
  by (metis fbd_disj le_iff_sup)

text \<open>The following counterexamples show that Infs are not preserved.\<close>

lemma "top_pres bd\<^sub>\<F>" (*nitpick*)
  oops

lemma "inf_pres bd\<^sub>\<F>" (*nitpick*)
  oops

text \<open>Dual preservation statements hold for ifbd ... and even Inf-preservation.\<close>

lemma ifbd_comp_pres: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> (\<phi> \<circ> \<psi>) = bd\<^sup>-\<^sub>\<F> \<psi> \<circ>\<^sub>K bd\<^sup>-\<^sub>\<F> \<phi>"
  by (smt fbd_ifbd_galois fun.map_comp kcomp_def klift_def)

lemma ifbd_Sup_pres: "Sup_pres bd\<^sup>-\<^sub>\<F>"
  by (simp add: fun_eq_iff)

lemma ifbd_sup_pres: "sup_pres bd\<^sup>-\<^sub>\<F>"
  by force

lemma ifbd_Inf_pres: "Inf_pres bd\<^sup>-\<^sub>\<F>"
  by (simp add: fun_eq_iff)

lemma ifbd_inf_pres: "inf_pres bd\<^sup>-\<^sub>\<F>"
  by force

lemma ifbd_bot_pres: "bot_pres bd\<^sup>-\<^sub>\<F>"
  by auto

lemma ifbd_top_pres: "top_pres bd\<^sup>-\<^sub>\<F>"
  by auto

text \<open>Preservation of units by the Kleisli lifting has been proved in klift-prop3.\<close>

text \<open>These results estabilish the isomorphism between state and predicate transformers given by backward diamonds.
The isomorphism preserves the Sup-quantale structure, but not Infs.\<close>

subsection \<open>Backward Diamonds from Relations\<close>

text \<open>Using the isomorphism between binary relations and Kleisli arrows (or state transformers), it is straightforward
to define backward diamonds from relations, by composing isomorphisms. It follows that Sup-quantales of binary relations
(under relational composition, the identity relation and Sups) are isomorphic to the Sup-quantales of predicate transformers.
Once again, Infs are not preserved.\<close>

definition rbd :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set"  ("bd\<^sub>\<R>") where
  "bd\<^sub>\<R> = bd\<^sub>\<F> \<circ> \<F>"

definition irbd :: "('a set \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set"  ("bd\<^sup>-\<^sub>\<R>") where
  "bd\<^sup>-\<^sub>\<R> = \<R> \<circ> bd\<^sup>-\<^sub>\<F>"

lemma rbd_Im: "bd\<^sub>\<R> = (``)"
  unfolding rbd_def klift_def r2f_def fun_eq_iff by force

lemma rbd_set: "bd\<^sub>\<R> R X = {y. \<exists>x \<in> X. (x,y) \<in> R}"
  by (force simp: rbd_Im Image_def)

lemma irbd_set: "bd\<^sup>-\<^sub>\<R> \<phi> = {(x,y). y \<in> (\<phi> \<circ> \<eta>) x}"
  by (simp add: irbd_def f2r_def o_def)

lemma irbd_set_var: "bd\<^sup>-\<^sub>\<R> \<phi> = {(x,y). y \<in> \<phi> {x}}"
  by (simp add: irbd_def f2r_def o_def)

lemma rbd_irbd_inv1 [simp]: "bd\<^sup>-\<^sub>\<R> \<circ> bd\<^sub>\<R> = id"
  by (metis (no_types, lifting) comp_eq_dest_lhs eq_id_iff fbd_Disj fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)

lemma irbd_rbd_inv2: "Sup_pres \<phi> \<Longrightarrow> (bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi>"
  by (metis comp_apply fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)

lemma irbd_rbd_inv2_inv: "(bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi> \<Longrightarrow> Sup_pres \<phi>"
  by (simp add: rbd_def irbd_def, metis fbd_Disj)

lemma irbd_rbd_inv2_iff: "((bd\<^sub>\<R> \<circ> bd\<^sup>-\<^sub>\<R>) \<phi> = \<phi>) = (Sup_pres \<phi>)"
  using irbd_rbd_inv2 irbd_rbd_inv2_inv by blast

lemma rbd_inj: "inj bd\<^sub>\<R>"
  by (simp add: fbd_inj inj_compose r2f_inj rbd_def)

lemma rbd_translate: "(bd\<^sub>\<R> R = bd\<^sub>\<R> S) = (R = S)"
  by (simp add: rbd_inj inj_eq)

lemma irbd_inj: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = bd\<^sup>-\<^sub>\<R> \<psi> \<Longrightarrow> \<phi> = \<psi>"
  by (metis rbd_Im comp_eq_dest_lhs irbd_rbd_inv2)

lemma irbd_inj_iff: "Sup_pres \<phi> \<Longrightarrow> Sup_pres \<psi> \<Longrightarrow> (bd\<^sup>-\<^sub>\<R> \<phi> = bd\<^sup>-\<^sub>\<R> \<psi>) = (\<phi> = \<psi>)"
  using irbd_inj by force

lemma rbd_surj: "Sup_pres \<phi> \<Longrightarrow> (\<exists>R. bd\<^sub>\<R> R = \<phi>)"
  using irbd_rbd_inv2 by force

lemma irbd_surj: "surj bd\<^sup>-\<^sub>\<R>"
  by (metis UNIV_I fun.set_map imageE rbd_irbd_inv1 surj_def surj_id)

lemma rbd_irbd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = bd\<^sub>\<R> R) = (R = bd\<^sup>-\<^sub>\<R> \<phi>)"
  by (smt comp_apply fbd_ifbd_galois irbd_def r2f_f2r_galois rbd_def)

lemma rbd_comp_pres: "bd\<^sub>\<R> (R ; S) = bd\<^sub>\<R> S \<circ> bd\<^sub>\<R> R"
  by (simp add: rbd_def r2f_comp_pres fbd_comp_pres)

lemma rbd_Id_pres: "bd\<^sub>\<R> Id = id"
  unfolding rbd_def by simp

lemma rbd_Un_pres: "Sup_pres bd\<^sub>\<R>"
  by (simp add: rbd_def Sup_pres_comp fbd_Sup_pres r2f_Sup_pres)

lemma rbd_un_pres: "sup_pres bd\<^sub>\<R>"
  by (simp add: rbd_def fbd_sup_pres r2f_sup_pres)

lemma "inf_pres bd\<^sub>\<R>" (*nitpick*)
  oops

lemma rbd_disj: "Sup_pres (bd\<^sub>\<R> R)"
  by (simp add: rbd_def fbd_Disj)

lemma rbd_disj2: "sup_pres (bd\<^sub>\<R> R)"
  by (simp add: Image_Un rbd_Im)

lemma rbd_bot_pres: "bot_pres bd\<^sub>\<R>"
  by (simp add: fbd_bot_pres r2f_bot_pres rbd_def)

lemma rbd_zero_pres2 [simp]: "bd\<^sub>\<R> R {} = {}"
  by (simp add: rbd_Im)

lemma rbd_univ: "bd\<^sub>\<R> R UNIV = Range R"
  unfolding rbd_def fun_eq_iff klift_def r2f_def by force

lemma rbd_iso: "X \<subseteq> Y \<Longrightarrow> bd\<^sub>\<R> R X \<subseteq> bd\<^sub>\<R> R Y"
  by (metis le_iff_sup rbd_disj2)

lemma irbd_comp_pres: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> (\<phi> \<circ> \<psi>) = bd\<^sup>-\<^sub>\<R> \<psi> ; bd\<^sup>-\<^sub>\<R> \<phi>"
  by (simp add: ifbd_comp_pres f2r_kcomp_pres irbd_def)

lemma irbd_id_pres [simp]: "bd\<^sup>-\<^sub>\<R> id = Id"
  unfolding irbd_def by simp

lemma irbd_Sup_pres: "Sup_pres bd\<^sup>-\<^sub>\<R>"
  by (simp add: irbd_def Sup_pres_comp ifbd_Sup_pres f2r_Sup_pres)

lemma irbd_sup_pres: "sup_pres bd\<^sup>-\<^sub>\<R>"
  by (simp add: irbd_def ifbd_sup_pres f2r_sup_pres)

lemma irbd_Inf_pres: "Inf_pres bd\<^sup>-\<^sub>\<R>"
  by (auto simp: fun_eq_iff irbd_def f2r_def)

lemma irbd_inf_pres: "inf_pres bd\<^sup>-\<^sub>\<R>"
  by (auto simp: fun_eq_iff irbd_def f2r_def)

lemma irbd_bot_pres: "bot_pres bd\<^sup>-\<^sub>\<R>"
  by (metis comp_def ifbd_bot_pres f2r_bot_pres irbd_def)

text \<open>This shows that relations are isomorphic to disjunctive forward predicate transformers. In many cases Isabelle picks up
the composition of morphisms in proofs.\<close>

subsection \<open>Forward Boxes on Kleisli Arrows\<close>

text \<open>Forward box operators correspond to weakest liberal preconditions in program semantics. Here,
Kleisli arrows are mapped to the opposite of the Eilenberg-Moore category, that is, Inf-lattices.
It follows that the Inf-quantale structure is preserved. Modelling opposition is based on the fact
that Kleisli arrows can be swapped by going through relations.\<close>

definition ffb :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fb\<^sub>\<F>") where
  "fb\<^sub>\<F> = \<partial>\<^sub>F \<circ> bd\<^sub>\<F> \<circ> op\<^sub>K"

text \<open>Here, $\partial_F$ is map-dual, which amounts to De Morgan duality. Hence the forward box operator is
obtained from the backward diamond by taking the opposite Kleisli arrow, applying the backward diamond, and then De Morgan
duality.\<close>

lemma ffb_prop: "fb\<^sub>\<F> f = \<partial> \<circ> bd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
  by (simp add: ffb_def map_dual_def)

lemma ffb_prop_var: "fb\<^sub>\<F> f = uminus \<circ> bd\<^sub>\<F> (op\<^sub>K f) \<circ> uminus"
  by (simp add: dual_set_def ffb_prop)

lemma ffb_fbd_dual: "\<partial> \<circ> fb\<^sub>\<F> f = bd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
  by (simp add: ffb_prop o_assoc)

text \<open>I give a set-theoretic definition of iffb, because the algebraic one below depends on Inf-preservation.\<close>

definition iffb :: "('b set \<Rightarrow> 'a set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("fb\<^sup>-\<^sub>\<F>") where
  "fb\<^sup>-\<^sub>\<F> \<phi> = (\<lambda>x. \<Inter>{X. x \<in> \<phi> X})"

lemma ffb_set: "fb\<^sub>\<F> f = (\<lambda>Y. {x. f x \<subseteq> Y})"
  by (force simp: fun_eq_iff ffb_prop_var kop_def klift_def f2r_def r2f_def)

text \<open>Forward boxes and backward diamonds are adjoints.\<close>

lemma ffb_fbd_galois: "(bd\<^sub>\<F> f) \<stileturn> (fb\<^sub>\<F> f)"
  unfolding adj_def ffb_set klift_prop by blast

lemma iffb_inv1: "fb\<^sup>-\<^sub>\<F> \<circ> fb\<^sub>\<F> = id"
  unfolding fun_eq_iff ffb_set iffb_def by force

lemma iffb_inv2_aux: "Inf_pres \<phi> \<Longrightarrow> \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y \<Longrightarrow> x \<in> \<phi> Y"
proof-
  assume "Inf_pres \<phi>"
    and h1: "\<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y"
  hence h2: "\<forall>X. \<phi> (\<Sqinter>X) = (\<Inter>x \<in> X. \<phi> x)"
    by (metis comp_eq_dest)
  hence "\<phi> (\<Sqinter>{X. x \<in> \<phi> X}) \<subseteq> \<phi> Y"
    by (metis h1 INF_lower2 cInf_eq_minimum mem_Collect_eq order_refl)
  hence "(\<Sqinter>{\<phi> X |X. x \<in> \<phi> X}) \<subseteq> \<phi> Y"
    by (metis h2 setcompr_eq_image)
  thus ?thesis
    by (force simp add: subset_iff)
qed

lemma iffb_inv2: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi>"
proof-
  assume h: "Inf_pres \<phi>"
  {fix Y
  have "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y = {x. \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y}"
    by (simp add: ffb_set iffb_def)
  hence "\<And>x. x \<in> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y \<longleftrightarrow> \<Sqinter>{X. x \<in> \<phi> X} \<subseteq> Y"
    by auto
  hence "\<And>x. x \<in> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y \<longleftrightarrow> x \<in> \<phi> Y"
    by (auto simp: h iffb_inv2_aux)
  hence  "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> Y = \<phi> Y"
    by (simp add: fun_eq_iff set_eq_iff)}
  thus ?thesis
    unfolding fun_eq_iff by simp
qed

lemma iffb_inv2_inv: "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi> \<Longrightarrow> Inf_pres \<phi>"
  by (auto simp: fun_eq_iff ffb_set iffb_def)

lemma iffb_inv2_iff: "((fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<phi> = \<phi>) = (Inf_pres \<phi>)"
  using iffb_inv2 iffb_inv2_inv by blast

lemma ffb_inj: "inj fb\<^sub>\<F>"
  unfolding inj_def by (metis iffb_inv1 pointfree_idE)

lemma ffb_inj_iff: "(fb\<^sub>\<F> f = fb\<^sub>\<F> g) = (f = g)"
  by (simp add: ffb_inj inj_eq)

lemma ffb_iffb_galois: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<F> \<phi> = f) = (fb\<^sub>\<F> f = \<phi>)"
  using ffb_inj_iff iffb_inv2 by force

lemma iffb_inj: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> fb\<^sup>-\<^sub>\<F> \<phi> = fb\<^sup>-\<^sub>\<F> \<psi>  \<Longrightarrow> \<phi> = \<psi>"
  by (metis ffb_iffb_galois)

lemma iffb_inj_iff: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<F> \<phi> = fb\<^sup>-\<^sub>\<F> \<psi>) = (\<phi> = \<psi>)"
  using iffb_inj by blast

lemma ffb_surj: "Inf_pres \<phi>  \<Longrightarrow> (\<exists>f. fb\<^sub>\<F> f = \<phi>)"
  using iffb_inv2 by auto

lemma iffb_surj: "surj fb\<^sup>-\<^sub>\<F>"
  using surj_def by (metis comp_apply iffb_inv1 surj_id)

text \<open>This is now the explicit "definition" of iffb, for Inf-preserving transformers.\<close>

lemma fbd_ffb_dual: "\<partial>\<^sub>F \<circ> fb\<^sub>\<F> \<circ> op\<^sub>K = bd\<^sub>\<F>"
proof-
  have "\<partial>\<^sub>F \<circ> fb\<^sub>\<F> \<circ> op\<^sub>K = \<partial>\<^sub>F \<circ> \<partial>\<^sub>F \<circ> bd\<^sub>\<F> \<circ> (op\<^sub>K \<circ> op\<^sub>K)"
    by (simp add: comp_def ffb_def)
  thus ?thesis
    by simp
qed

lemma ffbd_ffb_dual_var: "\<partial> \<circ> bd\<^sub>\<F> f = fb\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
  by (metis ffb_prop fun_dual1 kop_galois)

lemma ifbd_iffb_dual: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
proof-
  assume h: "Sup_pres \<phi>"
  hence "Inf_pres (\<partial>\<^sub>F \<phi>)"
    using Sup_pres_Inf_pres by blast
  hence "(op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi> = (op\<^sub>K \<circ> (op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<circ> \<partial>\<^sub>F) \<phi>"
    by (simp add: iffb_ifbd_dual)
  thus ?thesis
    by (metis comp_def kop_galois map_dual_dual)
qed

lemma ffb_kcomp_pres: "fb\<^sub>\<F> (f \<circ>\<^sub>K g) = fb\<^sub>\<F> f \<circ> fb\<^sub>\<F> g"
proof-
  have "fb\<^sub>\<F> (f \<circ>\<^sub>K g) = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K (f \<circ>\<^sub>K g)))"
    by (simp add: ffb_def)
  also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K g \<circ>\<^sub>K op\<^sub>K f))"
    by (simp add: kop_contrav)
  also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K f) \<circ> bd\<^sub>\<F> (op\<^sub>K g))"
    by (simp add: fbd_comp_pres)
  also have "... = \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K f)) \<circ> \<partial>\<^sub>F (bd\<^sub>\<F> (op\<^sub>K g))"
    by (simp add: map_dual_func1)
  finally show ?thesis
    by (simp add: ffb_def)
qed

lemma ffb_eta_pres: "fb\<^sub>\<F> \<eta> = id"
  unfolding ffb_def by simp

lemma ffb_Sup_dual: "Sup_dual fb\<^sub>\<F>"
  unfolding ffb_prop_var comp_def fun_eq_iff klift_prop kop_def f2r_def r2f_def converse_def by fastforce

lemma ffb_Sup_dual_var: "fb\<^sub>\<F> (\<Squnion>F) = (\<Sqinter>f \<in> F. fb\<^sub>\<F> f)"
  unfolding ffb_prop_var comp_def fun_eq_iff klift_prop kop_def f2r_def r2f_def converse_def by fastforce

lemma ffb_sup_dual: "sup_dual fb\<^sub>\<F>"
  using ffb_Sup_dual Sup_sup_dual by force

lemma ffb_zero_dual: "fb\<^sub>\<F> \<zeta> = (\<lambda>X. UNIV)"
  unfolding ffb_prop_var kop_def klift_prop fun_eq_iff f2r_def r2f_def by simp

lemma "inf_dual ffb" (*nitpick*)
  oops

text \<open>Once again, only the Sup-quantale structure is preserved.\<close>

lemma iffb_comp_pres:
  assumes "Inf_pres \<phi>"
  assumes "Inf_pres \<psi>"
  shows "fb\<^sup>-\<^sub>\<F> (\<phi> \<circ> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<circ>\<^sub>K fb\<^sup>-\<^sub>\<F> \<psi>"
    by (metis assms Inf_pres_comp ffb_iffb_galois ffb_kcomp_pres)

lemma iffb_Inf_dual:
  assumes "\<forall>\<phi> \<in> \<Phi>. Inf_pres \<phi>"
  shows "(fb\<^sup>-\<^sub>\<F> \<circ> Inf) \<Phi> = (Sup \<circ> \<P> fb\<^sup>-\<^sub>\<F>) \<Phi>"
proof-
  have "Inf_pres (\<Sqinter>\<Phi>)"
    using Inf_pres_Inf assms by blast
  hence "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) (\<Sqinter>\<Phi>) = \<Sqinter>(\<P> (fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) \<Phi>)"
    by (metis (mono_tags, lifting) INF_cong INF_identity_eq assms iffb_inv2)
  hence "(fb\<^sub>\<F> \<circ> fb\<^sup>-\<^sub>\<F>) (\<Sqinter>\<Phi>) = fb\<^sub>\<F> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<F> \<Phi>))"
    by (simp add: Setcompr_eq_image ffb_Sup_dual_var image_comp)
  thus ?thesis
    by (simp add: ffb_inj_iff)
qed

lemma iffb_Sup_dual: "Sup_dual fb\<^sup>-\<^sub>\<F>"
  by (auto simp: iffb_def fun_eq_iff)

lemma iffb_inf_dual:
  assumes "Inf_pres \<phi>"
  and "Inf_pres \<psi>"
shows "fb\<^sup>-\<^sub>\<F> (\<phi> \<sqinter> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<squnion> fb\<^sup>-\<^sub>\<F> \<psi>"
proof -
  have f1: "\<phi> \<sqinter> \<psi> = fb\<^sub>\<F> (fb\<^sup>-\<^sub>\<F> \<phi>) \<sqinter> fb\<^sub>\<F> (fb\<^sup>-\<^sub>\<F> \<psi>)"
    using assms iffb_inv2 by fastforce
  have "\<phi> \<sqinter> \<psi> \<circ> Inter = Inter \<circ> \<P> (\<phi> \<sqinter> \<psi>)"
    using assms Inf_pres_inf by blast
  thus ?thesis
    by (simp add: f1 ffb_iffb_galois ffb_sup_dual)
qed

lemma  iffb_sup_dual: "fb\<^sup>-\<^sub>\<F> (\<phi> \<squnion> \<psi>) = fb\<^sup>-\<^sub>\<F> \<phi> \<sqinter> fb\<^sup>-\<^sub>\<F> \<psi>"
  unfolding iffb_def by fastforce

lemma iffb_top_pres [simp]: "fb\<^sup>-\<^sub>\<F> \<top> = \<zeta>"
  unfolding iffb_def by simp

text \<open>This establishes the duality between state transformers and weakest liberal preconditions.\<close>

subsection \<open>Forward Box Operators from Relations\<close>

text \<open>Once again one can compose isomorphisms, linking weakest liberal preconditions with relational semantics.
The isomorphism obtained should by now be obvious.\<close>

definition rfb :: "('a \<times> 'b) set \<Rightarrow> 'b set \<Rightarrow> 'a set"  ("fb\<^sub>\<R>") where
  "fb\<^sub>\<R> = fb\<^sub>\<F> \<circ> \<F>"

definition irfb :: "('b set \<Rightarrow> 'a set) \<Rightarrow> ('a \<times> 'b) set" ("fb\<^sup>-\<^sub>\<R>") where
  "fb\<^sup>-\<^sub>\<R> = \<R> \<circ> fb\<^sup>-\<^sub>\<F>"

lemma rfb_rbd_dual: "fb\<^sub>\<R> R = \<partial>\<^sub>F (bd\<^sub>\<R> (R\<inverse>))"
  by (simp add: rfb_def rbd_def kop_def ffb_def, metis r2f_f2r_galois)

lemma rbd_rfb_dual: "bd\<^sub>\<R> R = \<partial>\<^sub>F (fb\<^sub>\<R> (R\<inverse>))"
  by (simp add: rfb_def rbd_def kop_def ffb_def, metis converse_converse map_dual_dual r2f_f2r_galois)

lemma irfb_irbd_dual: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> bd\<^sup>-\<^sub>\<R>  \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irfb_def irbd_def iffb_ifbd_dual kop_def r2f_f2r_galois)

lemma irbd_irfb_dual: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> fb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irfb_def irbd_def ifbd_iffb_dual kop_def r2f_f2r_galois)

lemma rfb_set: "fb\<^sub>\<R> R Y = {x. \<forall>y. (x,y) \<in> R \<longrightarrow> y \<in> Y}"
  unfolding rfb_def ffb_prop_var comp_def klift_def f2r_def r2f_def kop_def by force

lemma rfb_rbd_galois: "(bd\<^sub>\<R> R) \<stileturn> (fb\<^sub>\<R> R)"
  by (simp add: ffb_fbd_galois rbd_def rfb_def)

lemma irfb_set: "fb\<^sup>-\<^sub>\<R> \<phi> = {(x, y). \<forall>Y. x \<in> \<phi> Y \<longrightarrow> y \<in> Y}"
  by (simp add: irfb_def iffb_def f2r_def)

lemma irfb_inv1 [simp]: "fb\<^sup>-\<^sub>\<R> \<circ> fb\<^sub>\<R> = id"
  by (simp add: fun_eq_iff rfb_def irfb_def iffb_inv1 pointfree_idE)

lemma irfb_inv2: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) \<phi> = \<phi>"
  by (simp add: rfb_def irfb_def, metis ffb_iffb_galois r2f_f2r_galois)

lemma rfb_inj: "inj fb\<^sub>\<R>"
  by (simp add: rfb_def ffb_inj inj_compose r2f_inj)

lemma rfb_inj_iff: "(fb\<^sub>\<R> R = fb\<^sub>\<R> S) = (R = S)"
  by (simp add: rfb_inj inj_eq)

lemma irfb_inj: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi> = fb\<^sup>-\<^sub>\<R> \<psi> \<Longrightarrow> \<phi> = \<psi>"
  unfolding irfb_def using iffb_inj r2f_inj_iff by fastforce

lemma irfb_inf_iff: "Inf_pres \<phi> \<Longrightarrow> Inf_pres \<psi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<R> \<phi> = fb\<^sup>-\<^sub>\<R> \<psi>) = (\<phi> = \<psi>)"
  using irfb_inj by auto

lemma rfb_surj: "Inf_pres \<phi> \<Longrightarrow> (\<exists>R. fb\<^sub>\<R> R = \<phi>)"
  using irfb_inv2 by fastforce

lemma irfb_surj: "surj fb\<^sup>-\<^sub>\<R>"
  by (simp add: irfb_def comp_surj f2r_surj iffb_surj cong del: image_cong_simp)

lemma rfb_irfb_galois: "Inf_pres \<phi> \<Longrightarrow> (fb\<^sup>-\<^sub>\<R> \<phi> = R) = (fb\<^sub>\<R> R = \<phi>)"
  by (simp add: irfb_def rfb_def, metis ffb_iffb_galois r2f_f2r_galois)

lemma rfb_comp_pres: "fb\<^sub>\<R> (R ; S) = fb\<^sub>\<R> R \<circ> fb\<^sub>\<R> S"
  by (simp add: ffb_kcomp_pres r2f_comp_pres rfb_def)

lemma rfb_Id_pres [simp]: "fb\<^sub>\<R> Id = id"
  unfolding rfb_def ffb_prop by force

lemma rfb_Sup_dual: "Sup_dual fb\<^sub>\<R>"
proof-
  have "fb\<^sub>\<R> \<circ> \<mu> = fb\<^sub>\<F> \<circ> \<F> \<circ> Sup"
    by (simp add: rfb_def)
  also have "... = fb\<^sub>\<F> \<circ> Sup \<circ> \<P> \<F>"
    by (metis fun.map_comp r2f_Sup_pres)
  also have "... = Inf \<circ> \<P> fb\<^sub>\<F> \<circ> \<P> \<F>"
    by (simp add: ffb_Sup_dual)
  also have "... = Inf \<circ> \<P> (fb\<^sub>\<F> \<circ> \<F>)"
    by (simp add: P_func1 comp_assoc)
  finally show ?thesis
    by (simp add: rfb_def)
qed

lemma rfb_Sup_dual_var: "fb\<^sub>\<R> (\<Squnion>\<phi>) = \<Sqinter>(\<P> fb\<^sub>\<R>) \<phi>"
  by (meson comp_eq_dest rfb_Sup_dual)

lemma rfb_sup_dual: "sup_dual fb\<^sub>\<R>"
  by (simp add: rfb_def ffb_sup_dual r2f_sup_pres)

lemma "inf_dual fb\<^sub>\<R>" (*nitpick*)
  oops

lemma rfb_Inf_pres: "Inf_pres (fb\<^sub>\<R> R)"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma rfb_inf_pres: "inf_pres (fb\<^sub>\<R> R)"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma rfb_zero_pres [simp]: "fb\<^sub>\<R> {} X = UNIV"
 unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma rfb_zero_pres2 [simp]: "fb\<^sub>\<R> R {} = - Domain R"
 unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma rfb_univ [simp]: "fb\<^sub>\<R> R UNIV = UNIV"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma rfb_iso: "X \<subseteq> Y \<Longrightarrow> fb\<^sub>\<R> R X \<subseteq> fb\<^sub>\<R> R Y"
  unfolding rfb_def ffb_prop_var comp_def fun_eq_iff klift_def kop_def f2r_def r2f_def converse_def by auto

lemma irfb_comp_pres:
  assumes "Inf_pres \<phi>"
  assumes "Inf_pres \<psi>"
  shows "fb\<^sup>-\<^sub>\<R> (\<phi> \<circ> \<psi>) = fb\<^sup>-\<^sub>\<R> \<phi> ; fb\<^sup>-\<^sub>\<R> \<psi>"
  by (metis assms rfb_Inf_pres rfb_comp_pres rfb_irfb_galois)

lemma irfb_id_pres [simp]: "fb\<^sup>-\<^sub>\<R> id = Id"
  by (simp add: rfb_irfb_galois)

lemma irfb_Sup_dual: "Sup_dual fb\<^sup>-\<^sub>\<R>"
  by (auto simp: fun_eq_iff irfb_def iffb_def f2r_def)

lemma irfb_Inf_dual:
  assumes "\<forall>\<phi> \<in> \<Phi>. Inf_pres \<phi>"
  shows "(fb\<^sup>-\<^sub>\<R> \<circ> Inf) \<Phi> = (Sup \<circ> \<P> fb\<^sup>-\<^sub>\<R>) \<Phi>"
proof-
  have "Inf_pres (\<Sqinter>\<Phi>)"
    using Inf_pres_Inf assms by blast
  hence  "(fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) (\<Sqinter>\<Phi>) = \<Sqinter>(\<P> (fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) \<Phi>)"
    by (smt INF_identity_eq Sup.SUP_cong assms irfb_inv2)
  also have "... = \<Sqinter>(\<P> fb\<^sub>\<R> (\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))"
    by (simp add: image_comp)
  also have "... = fb\<^sub>\<R> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))"
    by (simp add: rfb_Sup_dual_var)
  finally have "(fb\<^sub>\<R> \<circ> fb\<^sup>-\<^sub>\<R>) (\<Sqinter>\<Phi>) = fb\<^sub>\<R> (\<Squnion>(\<P> fb\<^sup>-\<^sub>\<R> \<Phi>))".
  thus ?thesis
    by (simp add: rfb_inj_iff)
qed

lemma irfb_sup_dual: "sup_dual fb\<^sup>-\<^sub>\<R>"
  by (force simp: fun_eq_iff irfb_def iffb_def f2r_def)

lemma irfb_inf_dual:
  assumes "Inf_pres \<phi>"
  and "Inf_pres \<psi>"
  shows "fb\<^sup>-\<^sub>\<R> (\<phi> \<sqinter> \<psi>) = fb\<^sup>-\<^sub>\<R> \<phi> \<squnion> fb\<^sup>-\<^sub>\<R> \<psi>"
  by (metis assms rfb_Inf_pres rfb_irfb_galois rfb_sup_dual)

lemma irfb_top_pres [simp]: "bd\<^sup>-\<^sub>\<R> \<top> = UNIV"
  unfolding irbd_def f2r_def by auto

text \<open>Finally, the adjunctions between the predicate transformers considered so far are revisited.\<close>

lemma ffb_fbd_galois_var: "(bd\<^sub>\<F> f X \<subseteq> Y) = (X \<subseteq> fb\<^sub>\<F> f Y)"
  by (meson adj_def ffb_fbd_galois)

lemma rfb_rbd_galois_var: "(bd\<^sub>\<R> R X \<subseteq> Y) = (X \<subseteq> fb\<^sub>\<R> R Y)"
  by (meson adj_def rfb_rbd_galois)

lemma ffb_fbd: "fb\<^sub>\<F> f Y = \<Union>{X. bd\<^sub>\<F> f X \<subseteq> Y}"
  using ffb_fbd_galois_var by fastforce

lemma rfb_rbd: "fb\<^sub>\<R> R Y = \<Union>{X. bd\<^sub>\<R> R X \<subseteq> Y}"
  using rfb_rbd_galois_var by fastforce

lemma fbd_ffb: "bd\<^sub>\<F> f X = \<Inter>{Y. X \<subseteq> fb\<^sub>\<F> f Y}"
  using ffb_fbd_galois_var by fastforce

lemma rbd_rfb: "bd\<^sub>\<R> R X = \<Inter>{Y. X \<subseteq> fb\<^sub>\<R> R Y}"
  using rfb_rbd_galois_var by fastforce

subsection \<open>The Remaining Modalities\<close>

text \<open>Finally I set up the remaining dual transformers: forward diamonds and backward boxes.
Most properties are not repeated, only some symmetries and dualities are spelled out.\<close>

text \<open>First, forward diamond operators are introduced, from state transformers and relations; together
with their inverses.\<close>

definition ffd :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fd\<^sub>\<F>") where
  "fd\<^sub>\<F> = bd\<^sub>\<F> \<circ> op\<^sub>K"

definition iffd :: "('b set \<Rightarrow> 'a set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("fd\<^sup>-\<^sub>\<F>") where
  "fd\<^sup>-\<^sub>\<F> = op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F>"

definition rfd :: "('a \<times> 'b) set \<Rightarrow> 'b set \<Rightarrow> 'a set" ("fd\<^sub>\<R>") where
  "fd\<^sub>\<R> = fd\<^sub>\<F> \<circ> \<F>"

definition irfd :: "('b set \<Rightarrow> 'a set) \<Rightarrow> ('a \<times> 'b) set" ("fd\<^sup>-\<^sub>\<R>") where
  "fd\<^sup>-\<^sub>\<R> = \<R> \<circ> fd\<^sup>-\<^sub>\<F>"

text \<open>Second, I introduce forward boxes and their inverses.\<close>

definition fbb :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a set \<Rightarrow> 'b set" ("bb\<^sub>\<F>") where
  "bb\<^sub>\<F> = fb\<^sub>\<F> \<circ> op\<^sub>K"

definition ifbb :: "('a  set \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" ("bb\<^sup>-\<^sub>\<F>") where
 "bb\<^sup>-\<^sub>\<F> = op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>"

definition rbb :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" ("bb\<^sub>\<R>") where
  "bb\<^sub>\<R> = bb\<^sub>\<F> \<circ> \<F>"

definition irbb :: "('a  set \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set" ("bb\<^sup>-\<^sub>\<R>") where
  "bb\<^sup>-\<^sub>\<R> = \<R> \<circ> bb\<^sup>-\<^sub>\<F>"

text \<open>Forward and backward operators of the same type (box or diamond) are related by opposition.\<close>

lemma rfd_rbd: "fd\<^sub>\<R> = bd\<^sub>\<R> \<circ> (\<smile>)"
  by (simp add: rfd_def rbd_def ffd_def kop_def comp_assoc)

lemma irfd_irbd: "fd\<^sup>-\<^sub>\<R> = (\<smile>) \<circ> bd\<^sup>-\<^sub>\<R>"
  by (simp add: irfd_def iffd_def kop_def irbd_def comp_assoc[symmetric])

lemma fbd_ffd: "bd\<^sub>\<F> = fd\<^sub>\<F> \<circ> op\<^sub>K"
  by (simp add: ffd_def kop_def converse_def f2r_def r2f_def klift_def fun_eq_iff)

lemma rbb_rfb: "bb\<^sub>\<R> = fb\<^sub>\<R> \<circ> (\<smile>)"
  by (simp add: rfb_def rbb_def, metis fbb_def kop_def r2f_f2r_galois_var2 rewriteR_comp_comp2)

lemma irbb_irfb: "bb\<^sup>-\<^sub>\<R> = (\<smile>) \<circ> fb\<^sup>-\<^sub>\<R>"
proof-
  have "bb\<^sup>-\<^sub>\<R> = \<R> \<circ> op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>"
    by (simp add: irbb_def ifbb_def o_assoc)
  also have "... = \<R> \<circ> \<F> \<circ> (\<smile>) \<circ> \<R> \<circ> fb\<^sup>-\<^sub>\<F>"
    by (simp add: kop_def o_assoc)
  also have "... = (\<smile>) \<circ> fb\<^sup>-\<^sub>\<R>"
    by (simp add: comp_assoc irfb_def)
  finally show ?thesis.
qed

text \<open>Complementation is a natural isomorphism between forwards and backward operators of different type.\<close>

lemma ffd_ffb_demorgan: "\<partial> \<circ> fd\<^sub>\<F> f = fb\<^sub>\<F> f \<circ> \<partial>"
  by (simp add: comp_assoc ffb_prop ffd_def)

lemma iffd_iffb_demorgan: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<F> \<phi> = (fb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
  by (smt Sup_pres_Inf_pres comp_apply iffb_ifbd_dual iffd_def map_dual_dual)

lemma ffb_ffd_demorgan: "\<partial> \<circ> fb\<^sub>\<F> f = fd\<^sub>\<F> f \<circ> \<partial>"
  by (simp add: ffb_prop ffd_def rewriteL_comp_comp)

lemma iffb_iffd_demorgan: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<F> \<phi> = (fd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: iffb_ifbd_dual iffd_def)

lemma rfd_rfb_demorgan: "\<partial> \<circ> fd\<^sub>\<R> R = fb\<^sub>\<R> R \<circ> \<partial>"
  by (simp add: rfb_def rfd_def ffd_ffb_demorgan)

lemma irfd_irfb_demorgan: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<R> \<phi> = (fb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irfb_def irfd_def iffd_iffb_demorgan)

lemma rfb_rfd_demorgan: "\<partial> \<circ> fb\<^sub>\<R> R = fd\<^sub>\<R> R \<circ> \<partial>"
  by (simp add: ffb_ffd_demorgan rfb_def rfd_def)

lemma irfb_irfd_demorgan: "Inf_pres \<phi> \<Longrightarrow> fb\<^sup>-\<^sub>\<R> \<phi>  = (fd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irfb_irbd_dual irfd_irbd)

lemma fbd_fbb_demorgan: "\<partial> \<circ> bd\<^sub>\<F> f = bb\<^sub>\<F> f \<circ> \<partial>"
  by (simp add: fbb_def fbd_ffd ffd_ffb_demorgan)

lemma ifbd_ifbb_demorgan: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<F> \<phi> = (bb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: ifbd_iffb_dual ifbb_def)

lemma fbb_fbd_demorgan: "\<partial> \<circ> bb\<^sub>\<F> R = bd\<^sub>\<F> R \<circ> \<partial>"
  by (simp add: fbb_def fbd_ffd ffb_ffd_demorgan)

lemma ifbb_ifbd_demorgan: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<F> \<phi> = (bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
proof-
  assume h: "Inf_pres \<phi>"
  have "bb\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fb\<^sup>-\<^sub>\<F>) \<phi>"
    by (simp add: ifbb_def)
  also have "... = (op\<^sub>K \<circ> op\<^sub>K \<circ> bd\<^sup>-\<^sub>\<F>) (\<partial>\<^sub>F \<phi>)"
    by (metis comp_apply h iffb_ifbd_dual)
  also have "... = (bd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
    by auto
  finally show ?thesis.
qed

lemma rbd_rbb_demorgan: "\<partial> \<circ> bd\<^sub>\<R> R = bb\<^sub>\<R> R \<circ> \<partial>"
  by (simp add: rbb_def rbd_def fbd_fbb_demorgan)

lemma irbd_irbb_demorgan: "Sup_pres \<phi> \<Longrightarrow> bd\<^sup>-\<^sub>\<R> \<phi> = (bb\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irbb_irfb irbd_irfb_dual)

lemma rbb_rbd_demorgan: "\<partial> \<circ> bb\<^sub>\<R> R = bd\<^sub>\<R> R \<circ> \<partial>"
  by (simp add: rbb_def rbd_def fbb_fbd_demorgan)

lemma irbb_irbd_demorgan: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<R> \<phi> = (bd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irbb_def irbd_def ifbb_ifbd_demorgan)

text \<open>Further symmetries arise by combination.\<close>

lemma ffd_fbb_dual: "\<partial> \<circ> fd\<^sub>\<F> f = bb\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
  by (simp add: fbd_fbb_demorgan ffd_def)

lemma iffd_ifbb_dual: "Sup_pres \<phi> \<Longrightarrow> fd\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> bb\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: ifbd_ifbb_demorgan iffd_def)

lemma fbb_ffd_dual: "\<partial> \<circ> bb\<^sub>\<F> f = fd\<^sub>\<F> (op\<^sub>K f) \<circ> \<partial>"
  by (simp add: fbd_ffd fbb_fbd_demorgan)

lemma ifbb_iffd_dual: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<F> \<phi> = (op\<^sub>K \<circ> fd\<^sup>-\<^sub>\<F> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: ifbb_def iffb_iffd_demorgan)

lemma rfd_rbb_dual: "\<partial> \<circ> fd\<^sub>\<R> R = bb\<^sub>\<R> (R\<inverse>) \<circ> \<partial>"
  by (metis fun_dual1 map_dual_def rbd_rbb_demorgan rfb_rbd_dual rfd_rfb_demorgan)

lemma irbb_irfd_dual: "Inf_pres \<phi> \<Longrightarrow> bb\<^sup>-\<^sub>\<R> \<phi> = ((\<smile>) \<circ> fd\<^sup>-\<^sub>\<R> \<circ> \<partial>\<^sub>F) \<phi>"
  by (simp add: irbb_irfb irfb_irbd_dual irfd_irbd)

lemma ffd_iffd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = fd\<^sub>\<F> f) = (f = fd\<^sup>-\<^sub>\<F> \<phi>)"
  unfolding ffd_def iffd_def by (metis comp_apply fbd_surj klift_eta_inv1 kop_galois)

lemma rfd_irfd_galois: "Sup_pres \<phi> \<Longrightarrow> (\<phi> = fd\<^sub>\<R> R) = (R = fd\<^sup>-\<^sub>\<R> \<phi>)"
  unfolding irfd_def rfd_def by (metis comp_apply ffd_iffd_galois r2f_f2r_galois)

lemma fbb_ifbb_galois: "Inf_pres \<phi> \<Longrightarrow> (\<phi> = bb\<^sub>\<F> f) = (f = bb\<^sup>-\<^sub>\<F> \<phi>)"
  unfolding fbb_def iffb_def by (metis (no_types, lifting) comp_apply ffb_iffb_galois ifbb_ifbd_demorgan iffb_ifbd_dual kop_galois)

lemma rbb_irbb_galois: "Inf_pres \<phi> \<Longrightarrow> (\<phi> = bb\<^sub>\<R> R) = (R = bb\<^sup>-\<^sub>\<R> \<phi>)"
  apply (simp add: rbb_def irbb_def) using fbb_ifbb_galois r2f_f2r_galois by blast

text \<open>Next I spell out the missing adjunctions.\<close>

lemma ffd_ffb_adj: "fd\<^sub>\<F> f \<stileturn> bb\<^sub>\<F> f"
  by (simp add: fbb_def ffb_fbd_galois ffd_def)

lemma ffd_fbb_galois: "(fd\<^sub>\<F> f X \<subseteq> Y) = (X \<subseteq> bb\<^sub>\<F> f Y)"
  by (simp add: fbb_def ffb_fbd_galois_var ffd_def)

lemma rfd_rfb_adj: "fd\<^sub>\<R> f \<stileturn> bb\<^sub>\<R> f"
  by (simp add: ffd_ffb_adj rbb_def rfd_def)

lemma rfd_rbb_galois: "(fd\<^sub>\<R> R X \<subseteq> Y) = (X \<subseteq> bb\<^sub>\<R> R Y)"
  by (simp add: ffd_fbb_galois rbb_def rfd_def)

text \<open>Finally, forward and backward operators of the same type are linked by conjugation.\<close>

lemma ffd_fbd_conjugation: "(fd\<^sub>\<F> f X \<inter> Y = {}) = (X \<inter> bd\<^sub>\<F> f Y = {})"
proof-
  have "(fd\<^sub>\<F> f X \<inter> Y = {}) = (fd\<^sub>\<F> f X \<subseteq> -Y)"
    by (simp add: disjoint_eq_subset_Compl)
  also have "... = (X \<subseteq> bb\<^sub>\<F> f (-Y))"
    by (simp add: ffd_fbb_galois)
  also have "... = (X \<inter> - bb\<^sub>\<F> f (-Y) = {})"
    by (simp add: disjoint_eq_subset_Compl)
  also have "... = (X \<inter> \<partial> (bb\<^sub>\<F> f (\<partial> Y)) = {})"
    by (simp add: dual_set_def)
  finally show ?thesis
    by (metis (no_types, hide_lams) comp_apply fbb_fbd_demorgan invol_dual_var)
qed

lemma rfd_rbd_conjugation: "((fd\<^sub>\<R> R X) \<inter> Y = {}) = (X \<inter> (bd\<^sub>\<R> R Y) = {})"
  by (simp add: rbd_def rfd_def ffd_fbd_conjugation)

lemma ffb_fbb_conjugation: "((fb\<^sub>\<F> f X) \<union> Y = UNIV) = (X \<union> (bb\<^sub>\<F> f Y) = UNIV)"
proof-
  have "((fb\<^sub>\<F> f X) \<union> Y = UNIV) = (-Y \<subseteq> fb\<^sub>\<F> f X)"
    by blast
  also have "... = (bd\<^sub>\<F> f (\<partial> Y) \<subseteq> X)"
    by (simp add: ffb_fbd_galois_var dual_set_def)
  also have "... = (\<partial> (bb\<^sub>\<F> f Y) \<subseteq> X)"
    by (metis comp_def fbb_fbd_demorgan)
  also have "... = (X \<union> (bb\<^sub>\<F> f Y) = UNIV)"
    by (metis compl_le_swap2 dual_set_def join_shunt)
    finally show ?thesis.
qed

lemma rfb_rbb_conjugation: "((fb\<^sub>\<R> R X) \<union> Y = UNIV) = (X \<union> (bb\<^sub>\<R> R Y) = UNIV)"
  by (simp add: rfb_def rbb_def ffb_fbb_conjugation)

end


(*  Title:      HOL/Induct/Sigma_Algebra.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Sigma algebras\<close>

theory Sigma_Algebra
imports MainRLT
begin

text \<open>
  This is just a tiny example demonstrating the use of inductive
  definitions in classical mathematics.  We define the least \<open>\<sigma>\<close>-algebra over a given set of sets.
\<close>

inductive_set \<sigma>_algebra :: "'a set set \<Rightarrow> 'a set set" for A :: "'a set set"
where
  basic: "a \<in> \<sigma>_algebra A" if "a \<in> A" for a
| UNIV: "UNIV \<in> \<sigma>_algebra A"
| complement: "- a \<in> \<sigma>_algebra A" if "a \<in> \<sigma>_algebra A" for a
| Union: "(\<Union>i. a i) \<in> \<sigma>_algebra A" if "\<And>i::nat. a i \<in> \<sigma>_algebra A" for a

text \<open>
  The following basic facts are consequences of the closure properties
  of any \<open>\<sigma>\<close>-algebra, merely using the introduction rules, but
  no induction nor cases.
\<close>

theorem sigma_algebra_empty: "{} \<in> \<sigma>_algebra A"
proof -
  have "UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.UNIV)
  then have "-UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-UNIV = {}" by simp
  finally show ?thesis .
qed

theorem sigma_algebra_Inter:
  "(\<And>i::nat. a i \<in> \<sigma>_algebra A) \<Longrightarrow> (\<Inter>i. a i) \<in> \<sigma>_algebra A"
proof -
  assume "\<And>i::nat. a i \<in> \<sigma>_algebra A"
  then have "\<And>i::nat. -(a i) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  then have "(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.Union)
  then have "-(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed

end


theory Contexts
imports "HOL-Nominal.Nominal"
begin

text \<open>

  We show here that the Plotkin-style of defining
  beta-reduction (based on congruence rules) is
  equivalent to the Felleisen-Hieb-style representation
  (based on contexts).

  The interesting point in this theory is that contexts
  do not contain any binders. On the other hand the operation
  of filling a term into a context produces an alpha-equivalent
  term.

\<close>

atom_decl name

text \<open>
  Lambda-Terms - the Lam-term constructor binds a name
\<close>

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text \<open>
  Contexts - the lambda case in contexts does not bind
  a name, even if we introduce the notation [_]._ for CLam.
\<close>

nominal_datatype ctx =
    Hole ("\<box>" 1000)
  | CAppL "ctx" "lam"
  | CAppR "lam" "ctx"
  | CLam "name" "ctx"  ("CLam [_]._" [100,100] 100)

text \<open>Capture-Avoiding Substitution\<close>

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

text \<open>
  Filling is the operation that fills a term into a hole.
  This operation is possibly capturing.
\<close>

nominal_primrec
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
by (rule TrueI)+

text \<open>
  While contexts themselves are not alpha-equivalence classes, the
  filling operation produces an alpha-equivalent lambda-term.
\<close>

lemma alpha_test:
  shows "x\<noteq>y \<Longrightarrow> (CLam [x].\<box>) \<noteq> (CLam [y].\<box>)"
  and   "(CLam [x].\<box>)\<lbrakk>Var x\<rbrakk> = (CLam [y].\<box>)\<lbrakk>Var y\<rbrakk>"
by (auto simp add: alpha ctx.inject lam.inject calc_atm fresh_atm)

text \<open>The composition of two contexts.\<close>

nominal_primrec
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _" [100,100] 100)
where
  "\<box> \<circ> E' = E'"
| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
by (rule TrueI)+

lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

text \<open>Beta-reduction via contexts in the Felleisen-Hieb style.\<close>

inductive
  ctx_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>x _" [80,80] 80)
where
  xbeta[intro]: "E\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x E\<lbrakk>t[x::=t']\<rbrakk>"

text \<open>Beta-reduction via congruence rules in the Plotkin style.\<close>

inductive
  cong_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>o _" [80,80] 80)
where
  obeta[intro]: "App (Lam [x].t) t' \<longrightarrow>o t[x::=t']"
| oapp1[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t t2 \<longrightarrow>o App t' t2"
| oapp2[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t2 t \<longrightarrow>o App t2 t'"
| olam[intro]:  "t \<longrightarrow>o t' \<Longrightarrow> Lam [x].t \<longrightarrow>o Lam [x].t'"

text \<open>The proof that shows both relations are equal.\<close>

lemma cong_red_in_ctx:
  assumes a: "t \<longrightarrow>o t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>o E\<lbrakk>t'\<rbrakk>"
using a
by (induct E rule: ctx.induct) (auto)

lemma ctx_red_in_ctx:
  assumes a: "t \<longrightarrow>x t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>x E\<lbrakk>t'\<rbrakk>"
using a
by (induct) (auto simp add: ctx_compose[symmetric])

theorem ctx_red_implies_cong_red:
  assumes a: "t \<longrightarrow>x t'"
  shows "t \<longrightarrow>o t'"
using a by (induct) (auto intro: cong_red_in_ctx)

theorem cong_red_implies_ctx_red:
  assumes a: "t \<longrightarrow>o t'"
  shows "t \<longrightarrow>x t'"
using a
proof (induct)
  case (obeta x t' t)
  have "\<box>\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x \<box>\<lbrakk>t[x::=t']\<rbrakk>" by (rule xbeta)
  then show  "App (Lam [x].t) t' \<longrightarrow>x t[x::=t']" by simp
qed (metis ctx_red_in_ctx filling.simps)+ (* found by SledgeHammer *)

lemma ctx_existence:
  assumes a: "t \<longrightarrow>o t'"
  shows "\<exists>C s s'. t = C\<lbrakk>s\<rbrakk> \<and> t' = C\<lbrakk>s'\<rbrakk> \<and> s \<longrightarrow>o s'"
using a
by (induct) (metis cong_red.intros filling.simps)+

end


subsection\<open>Pedersen Commitment Scheme\<close>

text\<open>The Pedersen commitment scheme \<^cite>\<open>"DBLP:conf/crypto/Pedersen91"\<close> is a commitment scheme based on a cyclic group. We use the
construction of cyclic groups from CryptHOL to formalise the commitment scheme. We prove perfect hiding
and computational binding, with a reduction to the discrete log problem. We a proof of the Pedersen commitment scheme
is realised in the instantiation of the Schnorr \<open>\<Sigma>\<close>-protocol with the general construction of commitment schemes
from \<open>\<Sigma>\<close>-protocols. The commitment scheme that is realised there however take the inverse of the message in the commitment
phase due to the construction of the simulator in the \<open>\<Sigma>\<close>-protocol proof. The two schemes are in some way equal however
as we do not have a well defined notion of equality for commitment schemes we keep this section of the formalisation. This
also serves as reference to the formal proof of the Pedersen commitment scheme we provide in \<^cite>\<open>"DBLP:conf/post/ButlerAG19"\<close>.\<close>

theory Pedersen imports
  Commitment_Schemes
  "HOL-Number_Theory.Cong"
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
begin

locale pedersen_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes prime_order: "prime (order \<G>)"
begin

lemma order_gt_0 [simp]: "order \<G> > 0"
  by (simp add: prime_gt_0_nat prime_order)

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp'"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym "opening" = "nat"

definition key_gen :: "('grp ck \<times> 'grp vk) spmf"
where
  "key_gen = do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    return_spmf (h, h)
  }"

definition commit :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (ck [^] m);
    return_spmf (c,d)
  }"

definition commit_inv :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit_inv ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (inv ck [^] m);
    return_spmf (c,d)
  }"

definition verify :: "'grp vk \<Rightarrow> plain \<Rightarrow> 'grp commit \<Rightarrow> opening \<Rightarrow> bool"
where
  "verify v_key m c d = (c = (\<^bold>g [^] d \<otimes>  v_key [^] m))"

definition valid_msg :: "plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> (msg < order \<G>)"

definition dis_log_\ :: "('grp ck, plain, 'grp commit, opening) bind_adversary \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
where "dis_log_\ \ h = do {
  (c, m, d, m', d') \<leftarrow> \ h;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m'  \<and> valid_msg m \<and> valid_msg m');
  _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes> h [^] m \<and> c = \<^bold>g [^] d' \<otimes> h [^] m');
  return_spmf  (if (m > m') then (nat ((int d' - int d) * inverse (m - m') (order \<G>) mod order \<G>)) else
                  (nat ((int d - int d') * inverse (m' - m) (order \<G>) mod order \<G>)))}"

sublocale ped_commit: abstract_commitment key_gen commit verify valid_msg .

sublocale discrete_log: dis_log _
  unfolding dis_log_def by(simp)

end

locale pedersen = pedersen_base + cyclic_group \<G>
begin

lemma mod_one_cancel: assumes "[int y * z * x = y' * x] (mod order \<G>)" and "[z * x = 1] (mod order \<G>)"
  shows "[int y = y' * x] (mod order \<G>)"
  by (metis assms Groups.mult_ac(2) cong_scalar_right cong_sym_eq cong_trans more_arith_simps(11) more_arith_simps(5))

lemma dis_log_break:
  fixes d d' m m' :: nat
  assumes c: " \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m' = \<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m"
    and y_less_order: "y < order \<G>"
    and m_ge_m': "m > m'"
    and m: "m < order \<G>"
  shows "y = nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)"
proof -
  have mm': "\<not> [m = m'] (mod order \<G>)"
    using m m_ge_m' basic_trans_rules(19) cong_less_modulus_unique_nat by blast
  hence gcd: "int (gcd ((m - m')) (order \<G>)) = 1"
    using assms(3) assms(4) prime_field prime_order by auto
  have "\<^bold>g [^] (d + y * m) = \<^bold>g [^] (d' + y * m')"
    using c by (simp add: nat_pow_mult nat_pow_pow)
  hence "[d + y * m = d' + y * m'] (mod order \<G>)"
    by(simp add: pow_generator_eq_iff_cong finite_carrier)
  hence "[int d + int y * int m = int d' + int y * int m'] (mod order \<G>)"
    using cong_int_iff by force
  from cong_diff[OF this cong_refl, of "int d + int y * int m'"]
  have "[int y * int (m - m') = int d' - int d] (mod order \<G>)" using m_ge_m'
    by(simp add: int_distrib of_nat_diff)
  hence *: "[int y * int (m - m') * (fst (bezw ((m - m')) (order \<G>))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: cong_scalar_right)
  hence "[int y * (int (m - m') * (fst (bezw ((m - m')) (order \<G>)))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: more_arith_simps(11))
  hence "[int y * 1 = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    using inverse gcd
    by (smt Groups.mult_ac(2) Number_Theory_Aux.inverse Totient.of_nat_eq_1_iff * cong_def int_ops(9) mod_mult_right_eq mod_one_cancel)
  hence "[int y = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)" by simp
  hence "y mod order \<G> = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>"
    using cong_def zmod_int by auto
  thus ?thesis using y_less_order by simp
qed

lemma dis_log_break':
  assumes "y < order \<G>"
    and "\<not> m' < m"
    and "m \<noteq> m'"
    and m: "m' < order \<G>"
    and "\<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m'"
  shows "y = nat ((int d - int d') * fst (bezw ((m' - m)) (order \<G>)) mod int (order \<G>))"
proof-
  have "m' > m" using assms
    using group_eq_pow_eq_mod nat_neq_iff order_gt_0  by blast
  thus ?thesis
    using dis_log_break[of d y m d' m' ]assms cong_sym_eq assms by blast
qed

lemma set_spmf_samp_uni [simp]: "set_spmf (sample_uniform (order \<G>)) = {x. x < order \<G>}"
  by(auto simp add: sample_uniform_def)

lemma correct:
  shows "spmf (ped_commit.correct_game m) True  = 1"
  using finite_carrier order_gt_0_iff_finite
  apply(simp add: abstract_commitment.correct_game_def Let_def commit_def verify_def)
    by(simp add: key_gen_def Let_def bind_spmf_const cong: bind_spmf_cong_simp)

theorem abstract_correct:
  shows "ped_commit.correct"
  unfolding abstract_commitment.correct_def using correct by simp

lemma perfect_hiding:
  shows "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
  including monad_normalisation
proof -
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  note [simp] = Let_def split_def
  have "ped_commit.hiding_game_ind_cpa (\1, \2) = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (c,d) \<leftarrow> commit ck (if b then m0 else m1);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: abstract_commitment.hiding_game_ind_cpa_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
     b \<leftarrow> coin_spmf;
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = ((\<^bold>g [^] d) \<otimes> (h [^] (if b then m0 else m1)));
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: commit_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z \<otimes> (h [^] (if b then m0 else m1))) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
      by(simp add: bind_map_spmf o_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z. \<^bold>g [^] z) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by(simp add: sample_uniform_one_time_pad)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z)  (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    map_spmf((=) guess) coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
     by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis by(simp add: spmf_of_set)
qed

theorem abstract_perfect_hiding:
  shows "ped_commit.perfect_hiding_ind_cpa \"
proof-
  have "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
    using perfect_hiding by fastforce
  thus ?thesis
    by(simp add: abstract_commitment.perfect_hiding_ind_cpa_def abstract_commitment.hiding_advantage_ind_cpa_def)
qed

lemma bind_output_cong:
  assumes "x < order \<G>"
  shows "(x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>)))
            \<longleftrightarrow> [x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>))] (mod order \<G>)"
  using assms cong_less_modulus_unique_nat nat_less_iff by auto

lemma bind_game_eq_dis_log:
  shows "ped_commit.bind_game \ = discrete_log.dis_log (dis_log_\ \)"
proof-
  note [simp] = Let_def split_def
  have "ped_commit.bind_game \ = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    (c, m, d, m', d') \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf(m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    let b = verify vk m c d;
    let b' = verify vk m' c d';
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False"
    by(simp add: abstract_commitment.bind_game_alt_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (Coset.order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf True} ELSE return_spmf False"
    by(simp add: verify_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf (x = (if (m > m') then (nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)) else
                  (nat ((int d - int d') * (fst (bezw ((m' - m)) (order \<G>))) mod order \<G>))))} ELSE return_spmf False"
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
     apply(auto simp add: valid_msg_def)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
     apply(simp add: dis_log_break)
    apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
    by(simp add: dis_log_break')
  ultimately show ?thesis
    apply(simp add: discrete_log.dis_log_def dis_log_\_def cong: bind_spmf_cong_simp)
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
    using bind_output_cong by auto
qed

theorem pedersen_bind: "ped_commit.bind_advantage \ = discrete_log.advantage (dis_log_\ \)"
  unfolding abstract_commitment.bind_advantage_def discrete_log.advantage_def
  using bind_game_eq_dis_log by simp

end

locale pedersen_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes pedersen: "\<And>\<eta>. pedersen (\<G> \<eta>)"
begin

sublocale pedersen "\<G> \<eta>" for \<eta> by(simp add: pedersen)

theorem pedersen_correct_asym:
 shows "ped_commit.correct n"
  using abstract_correct by simp

theorem pedersen_perfect_hiding_asym:
  shows "ped_commit.perfect_hiding_ind_cpa n (\ n)"
    by (simp add: abstract_perfect_hiding)

theorem pedersen_bind_asym:
  shows "negligible (\<lambda> n. ped_commit.bind_advantage n (\ n))
            \<longleftrightarrow> negligible (\<lambda> n. discrete_log.advantage n (dis_log_\ n (\ n)))"
  by(simp add: pedersen_bind)

end

end


theory Exercises
imports Main
begin

datatype aexp = N int | V string | Plus aexp aexp

type_synonym val = "int"
type_synonym state = "string \<Rightarrow> int"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> int" where
"aval (N n) s = n" |
"aval (V x) s = s x"|
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = (N n)" |
"asimp_const (V s) = (V s)" |
"asimp_const (Plus a1 a2) =
(case (asimp_const a1, asimp_const a2) of
  ( N n1, N n2 ) \<Rightarrow> N (n1+n2) |
  ( b1, b2 ) \<Rightarrow> Plus b1 b2
)"

value"asimp_const (Plus (N 1) (Plus (N 2) (N 3)))"

fun myPlus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"myPlus (N n) (N m) = N(n+m)" |
"myPlus (N n) a = (if n = 0 then a else Plus (N n) a)" |
"myPlus a (N n) = (if n = 0 then a else Plus a (N n))" |
"myPlus a b = Plus a b"

lemma aval_plus[simp] : "aval (myPlus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction a1 rule:myPlus.induct)
  apply(auto)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = (N n)" |
"asimp (V s) = (V s)" |
"asimp (Plus a1 a2) = myPlus a1 a2"

lemma aval_asimp : "aval (asimp a) s = aval a s"
  apply(induction a rule: asimp.induct)
  apply(auto)
done

text \<open> Exercise 3.1 \<close>

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (Plus (N n) (N m)) = False" |
"optimal (N n) = True" |
"optimal (V s) = True" |
"optimal (Plus a1 a2) = conj (optimal a1) (optimal a2)"

lemma optimal_simplification : "optimal(asimp_const a) = True"
  apply(induction a)
  apply(auto split: aexp.split)
  done

text \<open> End of exercise 3.1 \<close>

text \<open> Exercise 3.2 \<close>

fun onlyN :: "aexp \<Rightarrow> int" where
"onlyN (N n) = n"|
"onlyN (V s) = 0"|
"onlyN (Plus a b) = onlyN a + onlyN b"

fun onlyV :: "aexp \<Rightarrow> aexp" where
"onlyV (N n) = (N 0)"|
"onlyV (V s) = (V s)"|
"onlyV (Plus a b) = asimp (Plus (onlyV a) (onlyV b))"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = Plus (N (onlyN a)) (onlyV a)"

value"full_asimp(Plus (N 1) (Plus (V x) (N 2)))"

theorem full_asimp_correctness : "aval (full_asimp a) s = aval a s"
  apply(induction a)
  apply(auto)
done

text \<open> End of exercise 3.2 \<close>

text \<open> Exercise 3.3 \<close>

fun subst :: "string \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst str inp (V s) = (if str = s then inp else (V s))"|
"subst str inp (N n) = (N n)"|
"subst str inp (Plus a b) = Plus (subst str inp a) (subst str inp b)"

value"subst ''x'' (N 3) (Plus (V ''x'') (V ''y''))"

lemma substitution_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
  apply(auto)
done

corollary substitution_consequence: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(induction e)
  apply(auto simp add: substitution_lemma)
done

text \<open> End of exercise 3.3 \<close>

text \<open> Exercise 3.4

datatype AExp = N int | V string | Plus AExp AExp | Mult AExp AExp

fun Aval :: "AExp \<Rightarrow> state \<Rightarrow> int" where
"Aval (N n) s = n" |
"Aval (V x) s = s x"|
"Aval (Plus a1 a2) s = (Aval a1 s) + (Aval a2 s)"|
"Aval (Mult a1 a2) s = (Aval a1 s) * (Aval a2 s)"

fun myPlus2 :: "AExp \<Rightarrow> AExp \<Rightarrow> AExp" where
"myPlus2 (N n) (N m) = N(n+m)" |
"myPlus2 (N n) a = (if n = 0 then a else Plus (N n) a)" |
"myPlus2 a (N n) = (if n = 0 then a else Plus a (N n))" |
"myPlus2 a b = Plus a b"

fun myMult :: "AExp \<Rightarrow> AExp \<Rightarrow> AExp" where
"myMult (N n) (N m) = N(n*m)" |
"myMult (N n) a = (if n = 0 then (N 0) else Mult (N n) a)" |
"myMult a (N n) = (if n = 0 then (N 0) else Mult a (N n))" |
"myMult a b = Mult a b"

fun Asimp_const :: "AExp \<Rightarrow> AExp" where
"Asimp_const (N n) = (N n)" |
"Asimp_const (V s) = (V s)" |
"Asimp_const (Plus a1 a2) =
(case (Asimp_const a1, Asimp_const a2) of
  ( N n1, N n2 ) \<Rightarrow> N (n1+n2) |
  ( b1, b2 ) \<Rightarrow> Plus b1 b2
)"|
"Asimp_const (Mult a1 a2) =
(case (Asimp_const a1, Asimp_const a2) of
  ( N n1, N n2 ) \<Rightarrow> N (n1*n2) |
  ( b1, b2 ) \<Rightarrow> Mult b1 b2
)"

fun Asimp :: "AExp \<Rightarrow> AExp" where
"Asimp (N n) = (N n)" |
"Asimp (V s) = (V s)" |
"Asimp (Plus a1 a2) = myPlus2 (Asimp_const a1) (Asimp_const a2)"|
"Asimp (Mult a1 a2) = myMult (Asimp_const a1) (Asimp_const a2)"

value"Asimp (Mult (N 0) ((Plus (V ''x'') (Mult (N 3) (N 5)))))"

 End of exercise 3.4 \<close>

datatype 'a option = None | Some 'a

text \<open> Exercise 3.5 \<close>

datatype aexp2 = N2 int | V2 string | Plus2 aexp2 aexp2 | PostInc string | Div2 aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state)" where
"aval2 (N2 n) st = ( n, st )"|
"aval2 (V2 s) st = ( st s, st )"|
"aval2 (Plus2 a b) st = ( fst (aval2 a st) + fst(aval2 b st), st )"|
"aval2 (PostInc s) st = (st s , st(s := 1 + st s))"|
"aval2 (Div2 a b) st = ( fst (aval2 a st) div fst (aval2 b st), st)"

text \<open> End of exercise 3.5 \<close>

text \<open> Exercise 3.6 \<close>

datatype lexp = Nl int | Vl string | Plusl lexp lexp | LET string lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl n) s = n"|
"lval (Vl x) s = s x"|
"lval (Plusl e1 e2) s = (lval e1 s) + (lval e2 s)"|
"lval (LET x e1 e2) s = lval e2 (s (x := (lval e1 s)))"

text \<open> y=3 -> y+3 = 6 -> x+y = x+6. \<close>
value"lval (LET ''y'' ( Plusl (Vl ''y'') (Nl 3) ) ( Plusl (Vl ''x'') (Vl ''y'') )) ((%x.0)(''y'' := 3::int))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = N n"|
"inline (Vl x) = V x"|
"inline (Plusl e1 e2) = Plus (inline e1) (inline e2)"|
"inline (LET x e1 e2) = subst x (inline e1) (inline e2)"

lemma "aval (inline e) s = lval e s"
  apply (induction e arbitrary:s)
  apply (auto simp add: substitution_lemma)
done

text \<open> End of exercise 3.6 \<close>

text \<open> Exercise 3.7 \<close>

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc b) s = b"|
"bval (Not b) s = (\<not> bval b s)"|
"bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)"|
"bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

value"not (Bc (bval (And (Bc True) (Bc False)) (%x.0)))"

fun andb :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"andb (Bc True) b = b"|
"andb b (Bc True) = b"|
"andb (Bc False) b = Bc False"|
"andb b (Bc False) = Bc False"|
"andb b1 b2 = And b1 b2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n1 ) (N n2 ) = Bc(n1 < n2 )" |
"less a1 a2 = Less a1 a2 "

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"|
"bsimp (And b1 b2) = andb (bsimp b1) (bsimp b2)"|
"bsimp (Not b) = not b"|
"bsimp (Bc b) = Bc b"

value"bsimp (And (And (Bc True) (Bc True)) (Less (N 10) (N 5)))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a1 a2 = (Not (Less a2 a1) )"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a1 a2 =(And ((Not (Less a2 a1) )) ((Not (Less a1 a2) )))"

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply (auto)
done

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply (auto)
done

text \<open> End of exercise 3.7 \<close>

text \<open> Exercise 3.8 \<close>

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b) s = b"|
"ifval (If a b c) s = (if (ifval a s) then (ifval b s) else (ifval c s))"|
"ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc b) = (Bc2 b)"|
"b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)"|
"b2ifexp (And a b) = If (b2ifexp a) (b2ifexp b) (Bc2 False)"|
"b2ifexp (Less a1 a2) = (Less2 a1 a2)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 b) = (Bc b)"|
"if2bexp (If a b c) = Not (And (Not (And (if2bexp a) (if2bexp b))) (Not (And (Not (if2bexp  a)) (if2bexp c))))"|
"if2bexp (Less2 a1 a2) = Less a1 a2"

lemma l1: "bval (if2bexp b) s = ifval b s"
  apply (induction b)
  apply (auto)
  done

lemma l2: "ifval (b2ifexp b) s = bval b s"
  apply (induction b)
  apply (auto)
done

text \<open> End of exercise 3.8 \<close>

text \<open> Exercise 3.9 \<close>

datatype pbexp = VAR string | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (string \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x ) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2 ) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2 ) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT p) = False" |
"is_nnf (AND p q) = (is_nnf p \<and> is_nnf q)" |
"is_nnf (OR p q) = (is_nnf p \<and> is_nnf q)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR x) = (VAR x)" |
"nnf (NOT (VAR x)) = (NOT (VAR x))" |
"nnf (NOT (NOT p)) = (nnf p)" |
"nnf (NOT (AND p q)) = (OR (nnf (NOT p)) (nnf (NOT q)))" |
"nnf (NOT (OR p q)) = (AND (nnf (NOT p)) (nnf (NOT q)))" |
"nnf (AND p q) = (AND (nnf p) (nnf q))"|
"nnf (OR p q) = (OR (nnf p) (nnf q))"

lemma preserves_the_value: "pbval (nnf b) s = pbval b s"
  apply(induction b rule:nnf.induct)
  apply(auto)
done

lemma is_actually_a_nnf: "is_nnf (nnf b)"
  apply(induction b rule:nnf.induct)
  apply(auto)
  done

fun no_or_in_and :: "pbexp \<Rightarrow> bool" where
"no_or_in_and (OR p q) = False" |
"no_or_in_and (AND p q) = ((no_or_in_and p) \<and> (no_or_in_and q))" |
"no_or_in_and a = True"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR p) = True"|
"is_dnf (NOT p) = True"|
"is_dnf (OR p q) = ((is_dnf p) \<and> (is_dnf q))"|
"is_dnf (AND p q) = ((no_or_in_and p) \<and> (no_or_in_and q))"

fun dist :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"dist p (OR q r) = OR (dist p q) (dist p r)" |
"dist (OR q r) p = OR (dist q p) (dist r p)" |
"dist p q = AND p q"

lemma pbval_dist: "pbval (dist a b) s = pbval (AND a b) s"
  apply (induction a b rule:dist.induct)
  apply (auto)
done

lemma is_dnf_dist: "is_dnf p \<Longrightarrow> is_dnf q \<Longrightarrow> is_dnf (dist p q)"
  apply (induction p q rule:dist.induct)
  apply (auto)
done

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT p) = NOT p" |
"dnf_of_nnf (OR p q) = OR (dnf_of_nnf p) (dnf_of_nnf q)" |
"dnf_of_nnf (AND p q) = dist (dnf_of_nnf p) (dnf_of_nnf q)"

theorem "pbval (dnf_of_nnf p) s = pbval p s"
  apply (induction p)
  apply (auto simp add: pbval_dist)
  done

theorem "is_nnf p \<Longrightarrow> is_dnf (dnf_of_nnf p)"
  apply (induction p rule:dnf_of_nnf.induct)
  apply (auto simp add: is_dnf_dist)
done

text \<open> End of exercise 3.9 \<close>
end


(*  Title:  HOL/ex/Arith_Examples.thy
    Author: Tjark Weber
*)

section {* Arithmetic *}

theory Arith_Examples
imports Main
begin

text {*
  The @{text arith} method is used frequently throughout the Isabelle
  distribution.  This file merely contains some additional tests and special
  corner cases.  Some rather technical remarks:

  @{ML Lin_Arith.simple_tac} is a very basic version of the tactic.  It performs no
  meta-to-object-logic conversion, and only some splitting of operators.
  @{ML Lin_Arith.tac} performs meta-to-object-logic conversion, full
  splitting of operators, and NNF normalization of the goal.  The @{text arith}
  method combines them both, and tries other methods (e.g.~@{text presburger})
  as well.  This is the one that you should use in your proofs!

  An @{text arith}-based simproc is available as well (see @{ML
  Lin_Arith.simproc}), which---for performance
  reasons---however does even less splitting than @{ML Lin_Arith.simple_tac}
  at the moment (namely inequalities only).  (On the other hand, it
  does take apart conjunctions, which @{ML Lin_Arith.simple_tac} currently
  does not do.)
*}

subsection {* Splitting of Operators: @{term max}, @{term min}, @{term abs},
           @{term minus}, @{term nat}, @{term Divides.mod},
           @{term Divides.div} *}

lemma "(i::nat) <= max i j"
  by linarith

lemma "(i::int) <= max i j"
  by linarith

lemma "min i j <= (i::nat)"
  by linarith

lemma "min i j <= (i::int)"
  by linarith

lemma "min (i::nat) j <= max i j"
  by linarith

lemma "min (i::int) j <= max i j"
  by linarith

lemma "min (i::nat) j + max i j = i + j"
  by linarith

lemma "min (i::int) j + max i j = i + j"
  by linarith

lemma "(i::nat) < j ==> min i j < max i j"
  by linarith

lemma "(i::int) < j ==> min i j < max i j"
  by linarith

lemma "(0::int) <= abs i"
  by linarith

lemma "(i::int) <= abs i"
  by linarith

lemma "abs (abs (i::int)) = abs i"
  by linarith

text {* Also testing subgoals with bound variables. *}

lemma "!!x. (x::nat) <= y ==> x - y = 0"
  by linarith

lemma "!!x. (x::nat) - y = 0 ==> x <= y"
  by linarith

lemma "!!x. ((x::nat) <= y) = (x - y = 0)"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y = d"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y - x = d - x"
  by linarith

lemma "(x::int) < y ==> x - y < 0"
  by linarith

lemma "nat (i + j) <= nat i + nat j"
  by linarith

lemma "i < j ==> nat (i - j) = 0"
  by linarith

lemma "(i::nat) mod 0 = i"
  (* rule split_mod is only declared by default for numerals *)
  using split_mod [of _ _ "0", arith_split]
  by linarith

lemma "(i::nat) mod 1 = 0"
  (* rule split_mod is only declared by default for numerals *)
  using split_mod [of _ _ "1", arith_split]
  by linarith

lemma "(i::nat) mod 42 <= 41"
  by linarith

lemma "(i::int) mod 0 = i"
  (* rule split_zmod is only declared by default for numerals *)
  using split_zmod [of _ _ "0", arith_split]
  by linarith

lemma "(i::int) mod 1 = 0"
  (* rule split_zmod is only declared by default for numerals *)
  using split_zmod [of _ _ "1", arith_split]
  by linarith

lemma "(i::int) mod 42 <= 41"
  by linarith

lemma "-(i::int) * 1 = 0 ==> i = 0"
  by linarith

lemma "[| (0::int) < abs i; abs i * 1 < abs i * j |] ==> 1 < abs i * j"
  by linarith

subsection {* Meta-Logic *}

lemma "x < Suc y == x <= y"
  by linarith

lemma "((x::nat) == z ==> x ~= y) ==> x ~= y | z ~= y"
  by linarith

subsection {* Various Other Examples *}

lemma "(x < Suc y) = (x <= y)"
  by linarith

lemma "[| (x::nat) < y; y < z |] ==> x < z"
  by linarith

lemma "(x::nat) < y & y < z ==> x < z"
  by linarith

text {* This example involves no arithmetic at all, but is solved by
  preprocessing (i.e. NNF normalization) alone. *}

lemma "(P::bool) = Q ==> Q = P"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> min (x::nat) y = 0"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> max (x::nat) y = x + y"
  by linarith

lemma "[| (x::nat) ~= y; a + 2 = b; a < y; y < b; a < x; x < b |] ==> False"
  by linarith

lemma "[| (x::nat) > y; y > z; z > x |] ==> False"
  by linarith

lemma "(x::nat) - 5 > y ==> y < x"
  by linarith

lemma "(x::nat) ~= 0 ==> 0 < x"
  by linarith

lemma "[| (x::nat) ~= y; x <= y |] ==> x < y"
  by linarith

lemma "[| (x::nat) < y; P (x - y) |] ==> P 0"
  by linarith

lemma "(x - y) - (x::nat) = (x - x) - y"
  by linarith

lemma "[| (a::nat) < b; c < d |] ==> (a - b) = (c - d)"
  by linarith

lemma "((a::nat) - (b - (c - (d - e)))) = (a - (b - (c - (d - e))))"
  by linarith

lemma "(n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
  (n = n' & n' < m) | (n = m & m < n') |
  (n' < m & m < n) | (n' < m & m = n) |
  (n' < n & n < m) | (n' = n & n < m) | (n' = m & m < n) |
  (m < n & n < n') | (m < n & n' = n) | (m < n' & n' < n) |
  (m = n & n < n') | (m = n' & n' < n) |
  (n' = m & m = (n::nat))"
(* FIXME: this should work in principle, but is extremely slow because     *)
(*        preprocessing negates the goal and tries to compute its negation *)
(*        normal form, which creates lots of separate cases for this       *)
(*        disjunction of conjunctions                                      *)
(* by (tactic {* Lin_Arith.tac 1 *}) *)
oops

lemma "2 * (x::nat) ~= 1"
(* FIXME: this is beyond the scope of the decision procedure at the moment, *)
(*        because its negation is satisfiable in the rationals?             *)
(* by (tactic {* Lin_Arith.simple_tac 1 *}) *)
oops

text {* Constants. *}

lemma "(0::nat) < 1"
  by linarith

lemma "(0::int) < 1"
  by linarith

lemma "(47::nat) + 11 < 8 * 15"
  by linarith

lemma "(47::int) + 11 < 8 * 15"
  by linarith

text {* Splitting of inequalities of different type. *}

lemma "[| (a::nat) ~= b; (i::int) ~= j; a < 2; b < 2 |] ==>
  a + b <= nat (max (abs i) (abs j))"
  by linarith

text {* Again, but different order. *}

lemma "[| (i::int) ~= j; (a::nat) ~= b; a < 2; b < 2 |] ==>
  a + b <= nat (max (abs i) (abs j))"
  by linarith

end