section \<open>Syntactic Matching in the Simplifier\<close>
theory Syntax_Match
imports Main
begin

subsection \<open>Non-Matching\<close>

text \<open>
  We define the predicates \<open>syntax_nomatch\<close>
  and \<open>syntax_fo_nomatch\<close>. The expression
  \<open>syntax_nomatch pattern object\<close> is simplified to true only if
  the term \<open>pattern\<close> syntactically matches the term \<open>object\<close>.
  Note that, semantically, \<open>syntax_nomatch pattern object\<close> is always
  true. While \<open>syntax_nomatch\<close> does higher-order matching,
  \<open>syntax_fo_nomatch\<close> does first-order matching.

  The intended application of these predicates are as guards for simplification
  rules, enforcing additional syntactic restrictions on the applicability of
  the simplification rule.
\<close>
definition syntax_nomatch :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  where syntax_nomatch_def: "syntax_nomatch pat obj \<equiv> True"
definition syntax_fo_nomatch :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  where syntax_fo_nomatch_def: "syntax_fo_nomatch pat obj \<equiv> True"

(* Prevent simplifier to simplify inside syntax_xx predicates *)
lemma [cong]: "syntax_fo_nomatch x y = syntax_fo_nomatch x y" by simp
lemma [cong]: "syntax_nomatch x y = syntax_nomatch x y" by simp

ML \<open>
structure Syntax_Match = struct
  val nomatch_thm = @{thm syntax_nomatch_def};
  val fo_nomatch_thm = @{thm syntax_fo_nomatch_def};

  fun fo_nomatch_simproc ctxt credex = let
    (*val ctxt = Simplifier.the_context ss;*)
    val thy = Proof_Context.theory_of ctxt;

    val redex = Thm.term_of credex;
    val (_,[pat,obj]) = strip_comb redex;

    fun fo_matches po = (Pattern.first_order_match
      thy po (Vartab.empty, Vartab.empty); true) handle Pattern.MATCH => false;
  in
    if fo_matches (pat,obj) then NONE else SOME fo_nomatch_thm
  end

  fun nomatch_simproc ctxt credex = let
    (*val ctxt = Simplifier.the_context ss;*)
    val thy = Proof_Context.theory_of ctxt;

    val redex = Thm.term_of credex;
    val (_,[pat,obj]) = strip_comb redex;
  in
    if Pattern.matches thy (pat,obj) then NONE else SOME nomatch_thm
  end
end
\<close>
simproc_setup nomatch ("syntax_nomatch pat obj")
  = \<open>K Syntax_Match.nomatch_simproc\<close>
simproc_setup fo_nomatch ("syntax_fo_nomatch pat obj")
  = \<open>K Syntax_Match.fo_nomatch_simproc\<close>

subsection \<open>Examples\<close>
subsubsection \<open>Ordering AC-structures\<close>
text \<open>
  Currently, the simplifier rules for ac-rewriting only work when
  associativity groups to the right. Here, we define rules that work for
  associativity grouping to the left. They are useful for operators where
  syntax is parsed (and pretty-printed) left-associative.
\<close>

locale ac_operator =
  fixes f
  assumes right_assoc: "f (f a b) c = f a (f b c)"
  assumes commute: "f a b = f b a"
begin
  lemmas left_assoc = right_assoc[symmetric]
  lemma left_commute: "f a (f b c) = f b (f a c)"
    apply (simp add: left_assoc)
    apply (simp add: commute)
    done

  lemmas right_ac = right_assoc left_commute commute

  lemma right_commute: "f (f a b) c = f (f a c) b"
    by (simp add: right_ac)

  lemma safe_commute: "syntax_fo_nomatch (f x y) a \<Longrightarrow> f a b = f b a"
    by (simp add: right_ac)

  lemmas left_ac = left_assoc right_commute safe_commute
end

interpretation mult: ac_operator "(*) ::'a::ab_semigroup_mult \<Rightarrow> _ \<Rightarrow> _"
  apply unfold_locales
  apply (simp_all add: ac_simps)
  done

interpretation add: ac_operator "(+) ::'a::ab_semigroup_add \<Rightarrow> _ \<Rightarrow> _"
  apply unfold_locales
  apply (simp_all add: ac_simps)
  done

text \<open>Attention: \<open>conj_assoc\<close> is in standard simpset, it has to be
  removed when using \<open>conj.left_ac\<close> !\<close>
interpretation conj: ac_operator "(\<and>)"
  by unfold_locales auto
interpretation disj: ac_operator "(\<or>)"
  by unfold_locales auto

end


header {* Some tactics *}

(* author: Andrei Popescu *)

theory MyTactics imports Main
begin

(* ML {* clarsimp_tac *}

ML{* val x = [1] @ [2] *}

ML {* simp_tac *}  *)

ML{*
val impI = @{thm impI}
val allI = @{thm allI}
val ballI = @{thm ballI}
val conjE = @{thm conjE}
val conjI = @{thm conjI}
val exE = @{thm exE}
val disjE = @{thm disjE}

fun mclarTacs i = [rtac impI i, rtac allI i, rtac ballI i, etac conjE i, etac exE i]
val mclarify_all_tac = REPEAT(SOMEGOAL(fn i => FIRST (mclarTacs i)))
fun mclarsimp_all_tac SS = (TRY mclarify_all_tac) THEN (TRYALL (asm_full_simp_tac SS))

fun mautoTacs i = mclarTacs i @ [rtac conjI i, etac disjE i]
val mauto_no_simp_tac = REPEAT(SOMEGOAL(fn i => FIRST (mautoTacs i)))

fun clarify_all_tac ctxt = TRYALL (clarify_tac ctxt)
*}

text{* Above, "m" stands for "mild" -- mainly, disjunctions are left untouched. *}

(* Note: The variables @{simpset} and @{claset} are *statically bound*,
hence they refer to the contents of the simp and classical databases at this
definition time.  For the classical database, this is OK for my purpose,
since all I care is that it includes HOL_cs.  However, for the simp database
I shall need to use the current version each time, since the database changes
continuously with simpliication rules for the newly defined concepts -- thereore
I shall need to pass that current version as an explicit parameter, which will
typically be (the current value of) @{simpset}.  *)

(*  Tests:
lemma "(\<forall> i j k. P \<longrightarrow> (Q1 \<or> Q2  \<and> [] @ L = L)) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> Q) \<and> D"
apply(tactic {* REPEAT(SOMEGOAL(rtac @{thm conjI})) *})
apply(tactic {* mclarify_all_tac *})
oops

lemma "V \<and> (\<forall> i j k. P \<longrightarrow> (Q1 \<or> Q2 \<and> [] @ L = L)) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> Q) \<and> D"
apply(tactic {* REPEAT(SOMEGOAL(rtac @{thm conjI})) *})
apply(tactic {* mclarsimp_all_tac @{simpset}*})
oops

lemma "V \<and> (\<forall> i j k. P \<longrightarrow> (Q1 \<or> Q2)) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> Q) \<and> D"
apply(tactic {* REPEAT(SOMEGOAL(rtac @{thm conjI})) *})
apply(tactic {* clarify_all_tac *})
apply(rule disjE)
oops

lemma "V \<and> (\<forall> i j k. P \<longrightarrow> (Q1 \<or> Q2 \<and> x = x)) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> Q) \<and> D"
apply(tactic {* REPEAT(SOMEGOAL(rtac @{thm conjI})) *})
apply(tactic {* clarsimp_all_tac @{simpset} *})
oops

lemma "(\<forall> i j k. P \<longrightarrow> Q) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> (Q \<and> R)) \<and> D"
apply(tactic {* REPEAT(SOMEGOAL(rtac @{thm conjI})) *})
apply(tactic {* mauto_no_simp_tac *})
oops

lemma test: "(\<forall> i j k. P \<longrightarrow> Q) \<and> (\<forall> a b. G a \<and> G b \<longrightarrow> Q)"
apply(tactic {* mauto_no_simp_tac *})
apply(rule disjE)
oops

*)

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, algorithms for iterators, min, max, to_sorted_list

*)

section {* \isaheader{Generic Algorithms for Sets} *}
theory SetGA
imports "../spec/SetSpec" SetIteratorCollectionsGA
begin
text_raw {*\label{thy:SetGA}*}

subsection {* Generic Set Algorithms *}

locale g_set_xx_defs_loc =
  s1: StdSetDefs ops1 + s2: StdSetDefs ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition "g_copy s \<equiv> s1.iterate s s2.ins_dj (s2.empty ())"
  definition "g_filter P s1 \<equiv> s1.iterate s1
    (\<lambda>x \<sigma>. if P x then s2.ins_dj x \<sigma> else \<sigma>)
    (s2.empty ())"

  definition "g_union s1 s2 \<equiv> s1.iterate s1 s2.ins s2"
  definition "g_diff s1 s2 \<equiv> s2.iterate s2 s1.delete s1"

  definition g_union_list where
    "g_union_list l =
      foldl (\<lambda>s s'. g_union s' s) (s2.empty ()) l"

  definition "g_union_dj s1 s2 \<equiv> s1.iterate s1 s2.ins_dj s2"

  definition "g_disjoint_witness s1 s2 \<equiv>
    s1.sel s1 (\<lambda>x. s2.memb x s2)"

  definition "g_disjoint s1 s2 \<equiv>
    s1.ball s1 (\<lambda>x. \<not>s2.memb x s2)"
end

locale g_set_xx_loc = g_set_xx_defs_loc ops1 ops2 +
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  lemma g_copy_alt:
    "g_copy s = iterate_to_set s2.empty s2.ins_dj (s1.iteratei s)"
    unfolding iterate_to_set_alt_def g_copy_def ..

    have LIS:
      "set_ins_dj s2.\<alpha> s2.invar s2.ins_dj"
      "set_empty s2.\<alpha> s2.invar s2.empty"
      by unfold_locales

    from iterate_to_set_correct[OF LIS s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_copy_alt
      by simp_all
  qed

  lemma g_filter_impl: "set_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_filter"
  proof
    fix s P
    assume "s1.invar s"
    hence "s2.\<alpha> (g_filter P s) = {e \<in> s1.\<alpha> s. P e} \<and>
      s2.invar (g_filter P s)" (is "?G1 \<and> ?G2")
      unfolding g_filter_def
      apply (rule_tac I="\<lambda>it \<sigma>. s2.invar \<sigma> \<and> s2.\<alpha> \<sigma> = {e \<in> it. P e}"
        in s1.iterate_rule_insert_P)
      by (auto simp add: s2.empty_correct s2.ins_dj_correct)
    thus ?G1 ?G2 by auto
  qed

  lemma g_union_alt:
    "g_union s1 s2 = iterate_add_to_set s2 s2.ins (s1.iteratei s1)"
    unfolding iterate_add_to_set_def g_union_def ..

  lemma g_diff_alt:
    "g_diff s1 s2 = iterate_diff_set s1 s1.delete (s2.iteratei s2)"
    unfolding g_diff_def iterate_diff_set_def ..

  lemma g_union_impl:
    "set_union s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union"
  proof -
    have LIS: "set_ins s2.\<alpha> s2.invar s2.ins" by unfold_locales
    from iterate_add_to_set_correct[OF LIS _ s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_union_alt
      by simp_all
  qed

  lemma g_diff_impl:
    "set_diff s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_diff"
  proof -
    have LIS: "set_delete s1.\<alpha> s1.invar s1.delete" by unfold_locales
    from iterate_diff_correct[OF LIS _ s2.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_diff_alt
      by simp_all
  qed

  lemma g_union_list_impl:
    shows "set_union_list s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_union_list"
  proof
    fix l
    note correct = s2.empty_correct set_union.union_correct[OF g_union_impl]

    assume "\<forall>s1\<in>set l. s1.invar s1"
    hence aux: "\<And>s. s2.invar s \<Longrightarrow>
           s2.\<alpha> (foldl (\<lambda>s s'. g_union s' s) s l)
           = \<Union>{s1.\<alpha> s1 |s1. s1 \<in> set l} \<union> s2.\<alpha> s \<and>
           s2.invar (foldl (\<lambda>s s'. g_union s' s) s l)"
      by (induct l) (auto simp add: correct)

    from aux [of "s2.empty ()"]
    show "s2.\<alpha> (g_union_list l) = \<Union>{s1.\<alpha> s1 |s1. s1 \<in> set l}"
         "s2.invar (g_union_list l)"
      unfolding g_union_list_def
      by (simp_all add: correct)
  qed

  lemma g_union_dj_impl:
    "set_union_dj s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union_dj"
  proof
    fix s1 s2
    assume I:
      "s1.invar s1"
      "s2.invar s2"
    assume DJ: "s1.\<alpha> s1 \<inter> s2.\<alpha> s2 = {}"

    have "s2.\<alpha> (g_union_dj s1 s2)
      = s1.\<alpha> s1 \<union> s2.\<alpha> s2
      \<and> s2.invar (g_union_dj s1 s2)" (is "?G1 \<and> ?G2")
      unfolding g_union_dj_def

      apply (rule_tac I="\<lambda>it \<sigma>. s2.invar \<sigma> \<and> s2.\<alpha> \<sigma> = it \<union> s2.\<alpha> s2"
        in s1.iterate_rule_insert_P)
      using DJ
      apply (simp_all add: I)
      apply (subgoal_tac "x\<notin>s2.\<alpha> \<sigma>")
      apply (simp add: s2.ins_dj_correct I)
      apply auto
      done
    thus ?G1 ?G2 by auto
  qed

  lemma g_disjoint_witness_impl:
    "set_disjoint_witness s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint_witness"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_witness_def
      by (auto dest: s1.sel'_noneD s1.sel'_someD simp: s2.memb_correct)
  qed

  lemma g_disjoint_impl:
    "set_disjoint s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: s2.memb_correct s1.ball_correct)
  qed
end

sublocale g_set_xx_loc <
  set_copy s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_copy by (rule g_copy_impl)

sublocale g_set_xx_loc <
  set_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_filter by (rule g_filter_impl)

sublocale g_set_xx_loc <
  set_union s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union
  by (rule g_union_impl)

sublocale g_set_xx_loc <
  set_union_dj s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union_dj
  by (rule g_union_dj_impl)

sublocale g_set_xx_loc <
  set_diff s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_diff
  by (rule g_diff_impl)

sublocale g_set_xx_loc <
  set_disjoint_witness s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint_witness
  by (rule g_disjoint_witness_impl)

sublocale g_set_xx_loc <
  set_disjoint s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint by (rule g_disjoint_impl)

(*sublocale StdBasicSetDefs < g_set_xx: g_set_xx_defs_loc ops ops .
sublocale StdBasicSet < g_set_xx: g_set_xx_loc ops ops
  by unfold_locales
*)

locale g_set_xxx_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  definition "g_inter s1 s2 \<equiv>
    s1.iterate s1 (\<lambda>x s. if s2.memb x s2 then s3.ins_dj x s else s)
      (s3.empty ())"
end

locale g_set_xxx_loc = g_set_xxx_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  lemma g_inter_impl: "set_inter s1.\<alpha> s1.invar s2.\<alpha> s2.invar s3.\<alpha> s3.invar
    g_inter"
  proof
    fix s1 s2
    assume I:
      "s1.invar s1"
      "s2.invar s2"
    have "s3.\<alpha> (g_inter s1 s2) = s1.\<alpha> s1 \<inter> s2.\<alpha> s2 \<and> s3.invar (g_inter s1 s2)"
      unfolding g_inter_def
      apply (rule_tac I="\<lambda>it \<sigma>. s3.\<alpha> \<sigma> = it \<inter> s2.\<alpha> s2 \<and> s3.invar \<sigma>"
        in s1.iterate_rule_insert_P)
      apply (simp_all add: I s3.empty_correct s3.ins_dj_correct s2.memb_correct)
      done
    thus "s3.\<alpha> (g_inter s1 s2) = s1.\<alpha> s1 \<inter> s2.\<alpha> s2"
      and "s3.invar (g_inter s1 s2)" by auto
  qed
end

sublocale g_set_xxx_loc
  < set_inter s1.\<alpha> s1.invar s2.\<alpha> s2.invar s3.\<alpha> s3.invar g_inter
  by (rule g_inter_impl)

(*sublocale StdBasicSetDefs < g_set_xxx: g_set_xxx_defs_loc ops ops ops .
sublocale StdBasicSet < g_set_xxx: g_set_xxx_loc ops ops ops
  by unfold_locales
*)

locale g_set_xy_defs_loc =
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  definition "g_image_filter f s \<equiv>
    s1.iterate s
      (\<lambda>x res. case f x of Some v \<Rightarrow> s2.ins v res | _ \<Rightarrow> res)
      (s2.empty ())"

  definition "g_image f s \<equiv>
    s1.iterate s (\<lambda>x res. s2.ins (f x) res) (s2.empty ())"

  definition "g_inj_image_filter f s \<equiv>
    s1.iterate s
      (\<lambda>x res. case f x of Some v \<Rightarrow> s2.ins_dj v res | _ \<Rightarrow> res)
      (s2.empty ())"

  definition "g_inj_image f s \<equiv>
    s1.iterate s (\<lambda>x res. s2.ins_dj (f x) res) (s2.empty ())"

end

locale g_set_xy_loc = g_set_xy_defs_loc ops1 ops2 +
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  lemma g_image_filter_impl:
    "set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image_filter"
  proof
    fix f s
    assume I: "s1.invar s"
    have A: "g_image_filter f s ==
         iterate_to_set s2.empty s2.ins
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_image_filter_def
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp

    have ins: "set_ins s2.\<alpha> s2.invar s2.ins"
      and emp: "set_empty s2.\<alpha> s2.invar s2.empty" by unfold_locales

    from iterate_image_filter_to_set_correct[OF ins emp s1.iteratei_correct]
    show "s2.\<alpha> (g_image_filter f s) =
          {b. \<exists>a\<in>s1.\<alpha> s. f a = Some b}"
         "s2.invar (g_image_filter f s)"
      unfolding A using I by auto
  qed

  lemma g_image_alt: "g_image f s = g_image_filter (Some o f) s"
    unfolding g_image_def g_image_filter_def
    by auto

  lemma g_image_impl: "set_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image"
  proof -
    interpret set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image_filter
      by (rule g_image_filter_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_image_alt
      by (auto simp add: image_filter_correct)
  qed

  lemma g_inj_image_filter_impl:
    "set_inj_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image_filter"
  proof
    fix f::"'x1 \<rightharpoonup> 'x2" and s
    assume I: "s1.invar s" and INJ: "inj_on f (s1.\<alpha> s \<inter> dom f)"
    have A: "g_inj_image_filter f s ==
         iterate_to_set s2.empty s2.ins_dj
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_inj_image_filter_def
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp

    have ins_dj: "set_ins_dj s2.\<alpha> s2.invar s2.ins_dj"
      and emp: "set_empty s2.\<alpha> s2.invar s2.empty" by unfold_locales

    from set_iterator_image_filter_correct[OF s1.iteratei_correct[OF I] INJ]
    have iti_s1_filter: "set_iterator
      (set_iterator_image_filter f (s1.iteratei s))
      {y. \<exists>x. x \<in> s1.\<alpha> s \<and> f x = Some y}"
      by simp

    from iterate_to_set_correct[OF ins_dj emp, OF iti_s1_filter]
    show "s2.\<alpha> (g_inj_image_filter f s) =
          {b. \<exists>a\<in>s1.\<alpha> s. f a = Some b}"
         "s2.invar (g_inj_image_filter f s)"
      unfolding A by auto
  qed

  lemma g_inj_image_alt: "g_inj_image f s = g_inj_image_filter (Some o f) s"
    unfolding g_inj_image_def g_inj_image_filter_def
    by auto

  lemma g_inj_image_impl:
    "set_inj_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image"
  proof -
    interpret set_inj_image_filter
      s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image_filter
      by (rule g_inj_image_filter_impl)

    have AUX: "\<And>S f. inj_on f S \<Longrightarrow> inj_on (Some \<circ> f) (S \<inter> dom (Some \<circ> f))"
      by (auto intro!: inj_onI dest: inj_onD)

    show ?thesis
      apply unfold_locales
      unfolding g_inj_image_alt
      by (auto simp add: inj_image_filter_correct AUX)

  qed

end

sublocale g_set_xy_loc < set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_image_filter by (rule g_image_filter_impl)

sublocale g_set_xy_loc < set_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_image by (rule g_image_impl)

sublocale g_set_xy_loc < set_inj_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_inj_image by (rule g_inj_image_impl)

locale g_set_xyy_defs_loc =
  s0: StdSetDefs ops0 +
  g_set_xx_defs_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition g_Union_image
    :: "('x0 \<Rightarrow> 's1) \<Rightarrow> 's0 \<Rightarrow> 's2"
    where "g_Union_image f S
    == s0.iterate S (\<lambda>x res. g_union (f x) res) (s2.empty ())"
end

locale g_set_xyy_loc = g_set_xyy_defs_loc ops0 ops1 ops2 +
  s0: StdSet ops0 +
  g_set_xx_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin

  lemma g_Union_image_impl:
    "set_Union_image s0.\<alpha> s0.invar s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_Union_image"
  proof -
    {
      fix s f
      have "\<lbrakk>s0.invar s; \<And>x. x \<in> s0.\<alpha> s \<Longrightarrow> s1.invar (f x)\<rbrakk> \<Longrightarrow>
        s2.\<alpha> (g_Union_image f s) = \<Union>(s1.\<alpha> ` f ` s0.\<alpha> s)
        \<and> s2.invar (g_Union_image f s)"
        apply (unfold g_Union_image_def)
        apply (rule_tac I="\<lambda>it res. s2.invar res
          \<and> s2.\<alpha> res = \<Union>(s1.\<alpha>`f`(s0.\<alpha> s - it))" in s0.iterate_rule_P)
        apply (fastforce simp add: s2.empty_correct union_correct)+
        done
    }
    thus ?thesis
      apply unfold_locales
      apply auto
      done
  qed
end

sublocale g_set_xyy_loc <
  set_Union_image s0.\<alpha> s0.invar s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_Union_image
  by (rule g_Union_image_impl)

subsection {* Default Set Operations*}

record ('x,'s) set_basic_ops =
  bset_op_\<alpha> :: "'s \<Rightarrow> 'x set"
  bset_op_invar :: "'s \<Rightarrow> bool"
  bset_op_empty :: "unit \<Rightarrow> 's"
  bset_op_memb :: "'x \<Rightarrow> 's \<Rightarrow> bool"
  bset_op_ins :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_ins_dj :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_delete :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_list_it :: "('x,'s) set_list_it"

record ('x,'s) oset_basic_ops = "('x::linorder,'s) set_basic_ops" +
  bset_op_ordered_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
  bset_op_rev_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"

locale StdBasicSetDefs =
  poly_set_iteratei_defs "bset_op_list_it ops"
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == bset_op_\<alpha> ops"
  abbreviation invar where "invar == bset_op_invar ops"
  abbreviation empty where "empty == bset_op_empty ops"
  abbreviation memb where "memb == bset_op_memb ops"
  abbreviation ins where "ins == bset_op_ins ops"
  abbreviation ins_dj where "ins_dj == bset_op_ins_dj ops"
  abbreviation delete where "delete == bset_op_delete ops"
  abbreviation list_it where "list_it \<equiv> bset_op_list_it ops"
end

locale StdBasicOSetDefs = StdBasicSetDefs ops
  + poly_set_iterateoi_defs "bset_op_ordered_list_it ops"
  + poly_set_rev_iterateoi_defs "bset_op_rev_list_it ops"
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
  abbreviation "ordered_list_it \<equiv> bset_op_ordered_list_it ops"
  abbreviation "rev_list_it \<equiv> bset_op_rev_list_it ops"
end

locale StdBasicSet = StdBasicSetDefs ops +
  set \<alpha> invar +
  set_empty \<alpha> invar empty +
  set_memb \<alpha> invar memb +
  set_ins \<alpha> invar ins +
  set_ins_dj \<alpha> invar ins_dj +
  set_delete \<alpha> invar delete +
  poly_set_iteratei \<alpha> invar list_it
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin

  lemmas correct[simp] =
    empty_correct
    memb_correct
    ins_correct
    ins_dj_correct
    delete_correct

end

locale StdBasicOSet =
  StdBasicOSetDefs ops +
  StdBasicSet ops +
  poly_set_iterateoi \<alpha> invar ordered_list_it +
  poly_set_rev_iterateoi \<alpha> invar rev_list_it
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
end

context StdBasicSetDefs
begin
  definition "g_sng x \<equiv> ins x (empty ())"
  definition "g_isEmpty s \<equiv> iteratei s (\<lambda>c. c) (\<lambda>_ _. False) True"
  definition "g_sel' s P \<equiv> iteratei s (op = None)
    (\<lambda>x _. if P x then Some x else None) None"

  definition "g_ball s P \<equiv> iteratei s (\<lambda>c. c) (\<lambda>x \<sigma>. P x) True"
  definition "g_bex s P \<equiv> iteratei s (\<lambda>c. \<not>c) (\<lambda>x \<sigma>. P x) False"
  definition "g_size s \<equiv> iteratei s (\<lambda>_. True) (\<lambda>x n . Suc n) 0"
  definition "g_size_abort m s \<equiv> iteratei s (\<lambda>\<sigma>. \<sigma> < m) (\<lambda>x. Suc) 0"
  definition "g_isSng s \<equiv> (iteratei s (\<lambda>\<sigma>. \<sigma> < 2) (\<lambda>x. Suc) 0 = 1)"

  definition "g_union s1 s2 \<equiv> iterate s1 ins s2"
  definition "g_diff s1 s2 \<equiv> iterate s2 delete s1"

  definition "g_subset s1 s2 \<equiv> g_ball s1 (\<lambda>x. memb x s2)"

  definition "g_equal s1 s2 \<equiv> g_subset s1 s2 \<and> g_subset s2 s1"

  definition "g_to_list s \<equiv> iterate s (op #) []"

  fun g_from_list_aux where
    "g_from_list_aux accs [] = accs" |
    "g_from_list_aux accs (x#l) = g_from_list_aux (ins x accs) l"
    -- {* Tail recursive version *}

  definition "g_from_list l == g_from_list_aux (empty ()) l"

  definition "g_inter s1 s2 \<equiv>
    iterate s1 (\<lambda>x s. if memb x s2 then ins_dj x s else s)
      (empty ())"

  definition "g_union_dj s1 s2 \<equiv> iterate s1 ins_dj s2"
  definition "g_filter P s \<equiv> iterate s
    (\<lambda>x \<sigma>. if P x then ins_dj x \<sigma> else \<sigma>)
    (empty ())"

  definition "g_disjoint_witness s1 s2 \<equiv> g_sel' s1 (\<lambda>x. memb x s2)"
  definition "g_disjoint s1 s2 \<equiv> g_ball s1 (\<lambda>x. \<not>memb x s2)"

  definition dflt_ops
    where [icf_rec_def]: "dflt_ops \<equiv> \<lparr>
      set_op_\<alpha> = \<alpha>,
      set_op_invar = invar,
      set_op_empty = empty,
      set_op_memb = memb,
      set_op_ins = ins,
      set_op_ins_dj = ins_dj,
      set_op_delete = delete,
      set_op_list_it = list_it,
      set_op_sng = g_sng ,
      set_op_isEmpty = g_isEmpty ,
      set_op_isSng = g_isSng ,
      set_op_ball = g_ball ,
      set_op_bex = g_bex ,
      set_op_size = g_size ,
      set_op_size_abort = g_size_abort ,
      set_op_union = g_union ,
      set_op_union_dj = g_union_dj ,
      set_op_diff = g_diff ,
      set_op_filter = g_filter ,
      set_op_inter = g_inter ,
      set_op_subset = g_subset ,
      set_op_equal = g_equal ,
      set_op_disjoint = g_disjoint ,
      set_op_disjoint_witness = g_disjoint_witness ,
      set_op_sel = g_sel' ,
      set_op_to_list = g_to_list ,
      set_op_from_list = g_from_list
    \<rparr>"

  local_setup {* Locale_Code.lc_decl_del @{term dflt_ops} *}
end

context StdBasicSet
begin

  lemma g_ins_dj_impl: "set_ins_dj \<alpha> invar ins"
    by unfold_locales (auto simp: ins_correct)

  lemma g_isEmpty_impl: "set_isEmpty \<alpha> invar g_isEmpty"
  proof
    fix s assume I: "invar s"
    have A: "g_isEmpty s = iterate_is_empty (iteratei s)"
      unfolding g_isEmpty_def iterate_is_empty_def ..
    from iterate_is_empty_correct[OF iteratei_correct[OF I]]
    show "g_isEmpty s \<longleftrightarrow> \<alpha> s = {}" unfolding A .
  qed

  lemma g_sel'_impl: "set_sel' \<alpha> invar g_sel'"
  proof -
    have A: "\<And>s P. g_sel' s P = iterate_sel_no_map (iteratei s) P"
      unfolding g_sel'_def iterate_sel_no_map_alt_def
      apply (rule arg_cong[where f="iteratei", THEN cong, THEN cong, THEN cong])
      by auto

    show ?thesis
      unfolding set_sel'_def A
      using iterate_sel_no_map_correct[OF iteratei_correct]
      apply (simp add: Bex_def Ball_def)
      apply (metis option.exhaust)
      done
  qed

  lemma g_ball_alt: "g_ball s P = iterate_ball (iteratei s) P"
    unfolding g_ball_def iterate_ball_def by (simp add: id_def)
  lemma g_bex_alt: "g_bex s P = iterate_bex (iteratei s) P"
    unfolding g_bex_def iterate_bex_def ..

  lemma g_bex_impl: "set_bex \<alpha> invar g_bex"
    apply unfold_locales
    unfolding g_bex_alt
    apply (rule iterate_bex_correct)
    by (rule iteratei_correct)

  lemma g_size_alt: "g_size s = iterate_size (iteratei s)"
    unfolding g_size_def iterate_size_def ..
  lemma g_size_abort_alt: "g_size_abort m s = iterate_size_abort (iteratei s) m"
    unfolding g_size_abort_def iterate_size_abort_def ..

  lemma g_size_impl: "set_size \<alpha> invar g_size"
    apply unfold_locales
    unfolding g_size_alt
    apply (rule conjunct1[OF iterate_size_correct])
    by (rule iteratei_correct)

  lemma g_size_abort_impl: "set_size_abort \<alpha> invar g_size_abort"
    apply unfold_locales
    unfolding g_size_abort_alt
    apply (rule conjunct1[OF iterate_size_abort_correct])
    by (rule iteratei_correct)

  lemma g_isSng_alt: "g_isSng s = iterate_is_sng (iteratei s)"
    unfolding g_isSng_def iterate_is_sng_def iterate_size_abort_def ..

  lemma g_isSng_impl: "set_isSng \<alpha> invar g_isSng"
    apply unfold_locales
    unfolding g_isSng_alt
    apply (drule iterate_is_sng_correct[OF iteratei_correct])
    apply (simp add: card_Suc_eq)
    done

  lemma g_union_impl: "set_union \<alpha> invar \<alpha> invar \<alpha> invar g_union"
    unfolding g_union_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P, simp_all)+
    done

  lemma g_diff_impl: "set_diff \<alpha> invar \<alpha> invar g_diff"
    unfolding g_diff_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = \<alpha> s1 - it"
      in iterate_rule_insert_P, auto)+
    done

  lemma g_subset_impl: "set_subset \<alpha> invar \<alpha> invar g_subset"
  proof -
    interpret set_ball \<alpha> invar g_ball by (rule g_ball_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_subset_def
      by (auto simp add: ball_correct memb_correct)
  qed

  lemma g_equal_impl: "set_equal \<alpha> invar \<alpha> invar g_equal"
  proof -
    interpret set_subset \<alpha> invar \<alpha> invar g_subset by (rule g_subset_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_equal_def
      by (auto simp add: subset_correct)
  qed

  lemma g_to_list_impl: "set_to_list \<alpha> invar g_to_list"
  proof
    fix s
    assume I: "invar s"
    have A: "g_to_list s = iterate_to_list (iteratei s)"
      unfolding g_to_list_def iterate_to_list_def ..

    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    show "set (g_to_list s) = \<alpha> s" and "distinct (g_to_list s)"
      unfolding A
      by auto
  qed

  lemma g_from_list_impl: "list_to_set \<alpha> invar g_from_list"
  proof -
    { -- "Show a generalized lemma"
      fix l accs
      have "invar accs \<Longrightarrow> \<alpha> (g_from_list_aux accs l) = set l \<union> \<alpha> accs
            \<and> invar (g_from_list_aux accs l)"
        by (induct l arbitrary: accs)
           (auto simp add: ins_correct)
    } thus ?thesis
      apply (unfold_locales)
      apply (unfold g_from_list_def)
      apply (auto simp add: empty_correct)
      done
  qed

  lemma g_inter_impl: "set_inter \<alpha> invar \<alpha> invar \<alpha> invar g_inter"
    unfolding g_inter_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> \<alpha> s2"
      in iterate_rule_insert_P, auto) []
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> \<alpha> s2"
      in iterate_rule_insert_P, auto)
    done

  lemma g_union_dj_impl: "set_union_dj \<alpha> invar \<alpha> invar \<alpha> invar g_union_dj"
    unfolding g_union_dj_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "x\<notin>\<alpha> \<sigma>")
    apply simp
    apply blast
    apply simp
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "x\<notin>\<alpha> \<sigma>")
    apply simp
    apply blast
    apply simp
    done

  lemma g_filter_impl: "set_filter \<alpha> invar \<alpha> invar g_filter"
    unfolding g_filter_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> Collect P"
      in iterate_rule_insert_P, auto)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> Collect P"
      in iterate_rule_insert_P, auto)
    done

  lemma g_disjoint_witness_impl: "set_disjoint_witness
    \<alpha> invar \<alpha> invar g_disjoint_witness"
  proof -
    interpret set_sel' \<alpha> invar g_sel' by (rule g_sel'_impl)
    show ?thesis
      unfolding g_disjoint_witness_def[abs_def]
      apply unfold_locales
      by (auto dest: sel'_noneD sel'_someD simp: memb_correct)
  qed

  lemma g_disjoint_impl: "set_disjoint
    \<alpha> invar \<alpha> invar g_disjoint"
  proof -
    interpret set_ball \<alpha> invar g_ball by (rule g_ball_impl)
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: memb_correct ball_correct)
  qed

end

context StdBasicSet
begin

context StdBasicOSetDefs
begin
  definition "g_min s P \<equiv> iterateoi s (\<lambda>x. x = None)
    (\<lambda>x _. if P x then Some x else None) None"
  definition "g_max s P \<equiv> rev_iterateoi s (\<lambda>x. x = None)
    (\<lambda>x _. if P x then Some x else None) None"

  definition "g_to_sorted_list s \<equiv> rev_iterateo s (op #) []"
  definition "g_to_rev_list s \<equiv> iterateo s (op #) []"

  definition dflt_oops :: "('x::linorder,'s) oset_ops"
    where [icf_rec_def]:
    "dflt_oops \<equiv> set_ops.extend
      dflt_ops
      \<lparr>
        set_op_ordered_list_it = ordered_list_it,
        set_op_rev_list_it = rev_list_it,
        set_op_min = g_min,
        set_op_max = g_max,
        set_op_to_sorted_list = g_to_sorted_list,
        set_op_to_rev_list = g_to_rev_list
      \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term dflt_oops} *}

end

context StdBasicOSet
begin
  lemma g_min_impl: "set_min \<alpha> invar g_min"
  proof
    fix s P

    assume I: "invar s"

    from iterateoi_correct[OF I]
    have iti': "set_iterator_linord (iterateoi s) (\<alpha> s)" by simp
    note sel_correct = iterate_sel_no_map_linord_correct[OF iti', of P]

    have A: "g_min s P = iterate_sel_no_map (iterateoi s) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix x
      assume "x\<in>\<alpha> s" "P x"
      with sel_correct
      show "g_min s P \<in> Some ` {x\<in>\<alpha> s. P x}" and "the (g_min s P) \<le> x"
        unfolding A by auto
    }

    { assume "{x\<in>\<alpha> s. P x} = {}"
       with sel_correct show "g_min s P = None"
        unfolding A by auto
    }
  qed

  lemma g_max_impl: "set_max \<alpha> invar g_max"
  proof
    fix s P

    assume I: "invar s"

    from rev_iterateoi_correct[OF I]
    have iti': "set_iterator_rev_linord (rev_iterateoi s) (\<alpha> s)" by simp
    note sel_correct = iterate_sel_no_map_rev_linord_correct[OF iti', of P]

    have A: "g_max s P = iterate_sel_no_map (rev_iterateoi s) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix x
      assume "x\<in>\<alpha> s" "P x"
      with sel_correct
      show "g_max s P \<in> Some ` {x\<in>\<alpha> s. P x}" and "the (g_max s P) \<ge> x"
        unfolding A by auto
    }

    { assume "{x\<in>\<alpha> s. P x} = {}"
       with sel_correct show "g_max s P = None"
        unfolding A by auto
    }
  qed

  lemma g_to_sorted_list_impl: "set_to_sorted_list \<alpha> invar g_to_sorted_list"
  proof
    fix s
    assume I: "invar s"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_rev_linord_correct[OF iti]
    show "sorted (g_to_sorted_list s)"
         "distinct (g_to_sorted_list s)"
         "set (g_to_sorted_list s) = \<alpha> s"
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "set_to_rev_list \<alpha> invar g_to_rev_list"
  proof
    fix s
    assume I: "invar s"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_linord_correct[OF iti]
    show "sorted (rev (g_to_rev_list s))"
         "distinct (g_to_rev_list s)"
         "set (g_to_rev_list s) = \<alpha> s"
      unfolding g_to_rev_list_def iterate_to_list_def
      by (simp_all)
  qed

  lemma dflt_oops_impl: "StdOSet dflt_oops"
  proof -
    interpret aux: StdSet dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOSet_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

subsection "More Generic Set Algorithms"
text {*
  These algorithms do not have a function specification in a locale, but
  their specification is done  ad-hoc in the correctness lemma.
*}

subsubsection "Image and Filter of Cartesian Product"

locale image_filter_cp_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (\<lambda>x res.
      s2.iterate s2 (\<lambda>y res.
        case (f (x, y)) of
          None \<Rightarrow> res
        | Some z \<Rightarrow> (s3.ins z res)
      ) res
    ) (s3.empty ())"

  lemma image_filter_cartesian_product_alt:
    "image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2)))"
    unfolding image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def
    by simp

  definition image_filter_cp where
    "image_filter_cp f P s1 s2 \<equiv>
     image_filter_cartesian_product
      (\<lambda>xy. if P xy then Some (f xy) else None) s1 s2"

end

locale image_filter_cp_loc = image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma image_filter_cartesian_product_correct:
    fixes f :: "'x \<times> 'y \<rightharpoonup> 'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.\<alpha> (image_filter_cartesian_product f s1 s2)
     = { z | x y z. f (x,y) = Some z \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator
        (set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2))
        (s1.\<alpha> s1 \<times> s2.\<alpha> s2)"
        by simp

      have LIS:
        "set_ins s3.\<alpha> s3.invar s3.ins"
        "set_empty s3.\<alpha> s3.invar s3.empty"
        by unfold_locales

      from iterate_image_filter_to_set_correct[OF LIS it_s12, of f]
      show ?T1 ?T2
        unfolding image_filter_cartesian_product_alt by auto
  qed

  lemma image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    shows
    "s3.\<alpha> (image_filter_cp f P s1 s2)
     = { f (x, y) | x y. P (x, y) \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    from image_filter_cartesian_product_correct [OF I]
    show "?T1" "?T2"
      unfolding image_filter_cp_def
      by auto
  qed

end

locale inj_image_filter_cp_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "inj_image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (\<lambda>x res.
      s2.iterate s2 (\<lambda>y res.
        case (f (x, y)) of
          None \<Rightarrow> res
        | Some z \<Rightarrow> (s3.ins_dj z res)
      ) res
    ) (s3.empty ())"

  lemma inj_image_filter_cartesian_product_alt:
    "inj_image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins_dj (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2)))"
    unfolding inj_image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def
    by simp

  definition inj_image_filter_cp where
    "inj_image_filter_cp f P s1 s2 \<equiv>
     inj_image_filter_cartesian_product
      (\<lambda>xy. if P xy then Some (f xy) else None) s1 s2"

end

locale inj_image_filter_cp_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma inj_image_filter_cartesian_product_correct:
    fixes f :: "'x \<times> 'y \<rightharpoonup> 'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f (s1.\<alpha> s1 \<times> s2.\<alpha> s2 \<inter> dom f)"
    shows "s3.\<alpha> (inj_image_filter_cartesian_product f s1 s2)
     = { z | x y z. f (x,y) = Some z \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator
        (set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2))
        (s1.\<alpha> s1 \<times> s2.\<alpha> s2)"
        by simp

      have LIS:
        "set_ins_dj s3.\<alpha> s3.invar s3.ins_dj"
        "set_empty s3.\<alpha> s3.invar s3.empty"
        by unfold_locales

      from iterate_inj_image_filter_to_set_correct[OF LIS it_s12 INJ]
      show ?T1 ?T2
        unfolding inj_image_filter_cartesian_product_alt by auto
  qed

  lemma inj_image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f {x\<in>s1.\<alpha> s1 \<times> s2.\<alpha> s2. P x}"
    shows
    "s3.\<alpha> (inj_image_filter_cp f P s1 s2)
     = { f (x, y) | x y. P (x, y) \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    let ?f = "\<lambda>xy. if P xy then Some (f xy) else None"
    from INJ have INJ': "inj_on ?f (s1.\<alpha> s1 \<times> s2.\<alpha> s2 \<inter> dom ?f)"
      by (force intro!: inj_onI dest: inj_onD split: split_if_asm)

    from inj_image_filter_cartesian_product_correct [OF I INJ']
    show "?T1" "?T2"
      unfolding inj_image_filter_cp_def
      by auto
  qed

end

subsubsection "Cartesian Product"

locale cart_defs_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x\<times>'y,'s3,'more3) set_ops_scheme"
begin

  definition "cart s1 s2 \<equiv>
    s1.iterate s1
      (\<lambda>x. s2.iterate s2 (\<lambda>y res. s3.ins_dj (x,y) res))
      (s3.empty ())"

  lemma cart_alt: "cart s1 s2 ==
    inj_image_filter_cartesian_product Some s1 s2"
    unfolding cart_def inj_image_filter_cartesian_product_def
    by simp

end

locale cart_loc = cart_defs_loc ops1 ops2 ops3
  + inj_image_filter_cp_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x\<times>'y,'s3,'more3) set_ops_scheme"
begin

  lemma cart_correct:
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.\<alpha> (cart s1 s2)
           = s1.\<alpha> s1 \<times> s2.\<alpha> s2" (is ?T1)
    "s3.invar (cart s1 s2)" (is ?T2)
    unfolding cart_alt
    by (auto simp add:
      inj_image_filter_cartesian_product_correct[OF I, where f=Some])

end

subsection {* Generic Algorithms outside basic-set *}
text {*
  In this section, we present some generic algorithms that are not
  formulated in terms of basic-set. They are useful for setting up
  some data structures.
*}

subsection {* Image (by image-filter) *}
definition "iflt_image iflt f s == iflt (\<lambda>x. Some (f x)) s"

lemma iflt_image_correct:
  assumes "set_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_image \<alpha>1 invar1 \<alpha>2 invar2 (iflt_image iflt)"
proof -
  interpret set_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact
  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def)
    apply (auto simp add: image_filter_correct)
    done
qed

subsection{* Injective Image-Filter (by image-filter)*}

definition [code_unfold]: "iflt_inj_image = iflt_image"

lemma iflt_inj_image_correct:
  assumes "set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_inj_image \<alpha>1 invar1 \<alpha>2 invar2 (iflt_inj_image iflt)"
proof -
  interpret set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact

  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def iflt_inj_image_def)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    done
qed

subsection{* Filter (by image-filter)*}
definition "iflt_filter iflt P s == iflt (\<lambda>x. if P x then Some x else None) s"

lemma iflt_filter_correct:
  fixes \<alpha>1 :: "'s1 \<Rightarrow> 'a set"
  fixes \<alpha>2 :: "'s2 \<Rightarrow> 'a set"
  assumes "set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_filter \<alpha>1 invar1 \<alpha>2 invar2 (iflt_filter iflt)"
proof (rule set_filter.intro)
  fix s P
  assume invar_s: "invar1 s"
  interpret S: set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact

  let ?f' = "\<lambda>x::'a. if P x then Some x else None"
  have inj_f': "inj_on ?f' (\<alpha>1 s \<inter> dom ?f')"
    by (simp add: inj_on_def Ball_def domIff)
  note correct' = S.inj_image_filter_correct [OF invar_s inj_f',
    folded iflt_filter_def]

  show "invar2 (iflt_filter iflt P s)"
       "\<alpha>2 (iflt_filter iflt P s) = {e \<in> \<alpha>1 s. P e}"
    by (auto simp add: correct')
qed

end


section \<open> Alphabetised Relations \<close>

theory utp_rel
imports
  utp_pred_laws
  utp_healthy
  utp_lift
  utp_tactics
begin

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

subsection \<open> Relational Alphabets \<close>

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

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

definition out\<alpha> :: "('\<beta> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out\<alpha> = snd\<^sub>L"

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma var_in_alpha [simp]: "x ;\<^sub>L in\<alpha> = ivar x"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma var_out_alpha [simp]: "x ;\<^sub>L out\<alpha> = ovar x"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp)

lemma usubst_lookup_ivar_unrest [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ivar x) = $x"
  by (rel_simp, metis fstI)

lemma usubst_lookup_ovar_unrest [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (ovar x) = $x\<acute>"
  by (rel_simp, metis sndI)

lemma out_alpha_in_indep [simp]:
  "out\<alpha> \<bowtie> in_var x" "in_var x \<bowtie> out\<alpha>"
  by (simp_all add: in_var_def out\<alpha>_def lens_indep_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_alpha_out_indep [simp]:
  "in\<alpha> \<bowtie> out_var x" "out_var x \<bowtie> in\<alpha>"
  by (simp_all add: in_var_def in\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

text \<open> The following two functions lift a predicate substitution to a relational one. \<close>

abbreviation usubst_rel_lift :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<times> '\<beta>) usubst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> \<sigma> \<oplus>\<^sub>s in\<alpha>"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) usubst \<Rightarrow> '\<alpha> usubst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> \<sigma> \<restriction>\<^sub>s in\<alpha>"

text \<open> The alphabet of a relation then consists wholly of the input and output portions. \<close>

lemma alpha_in_out:
  "\<Sigma> \<approx>\<^sub>L in\<alpha> +\<^sub>L out\<alpha>"
  by (simp add: fst_snd_id_lens in\<alpha>_def lens_equiv_refl out\<alpha>_def)

subsection \<open> Relational Types and Operators \<close>

text \<open> We create type synonyms for conditions (which are simply predicates) -- i.e. relations
  without dashed variables --, alphabetised relations where the input and output alphabet can
  be different, and finally homogeneous relations. \<close>

type_synonym '\<alpha> cond        = "'\<alpha> upred"
type_synonym ('\<alpha>, '\<beta>) urel  = "('\<alpha> \<times> '\<beta>) upred"
type_synonym '\<alpha> hrel        = "('\<alpha> \<times> '\<alpha>) upred"
type_synonym ('a, '\<alpha>) hexpr = "('a, '\<alpha> \<times> '\<alpha>) uexpr"

translations
  (type) "('\<alpha>, '\<beta>) urel" <= (type) "('\<alpha> \<times> '\<beta>) upred"

text \<open> We set up some overloaded constants for sequential composition and the identity in case
  we want to overload their definitions later. \<close>

consts
  useq     :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 61)
  uassigns :: "'a usubst \<Rightarrow> 'b" ("\<langle>_\<rangle>\<^sub>a")
  uskip    :: "'a" ("II")

text \<open> We define a specialised version of the conditional where the condition can refer only to
  undashed variables, as is usually the case in programs, but not universally in UTP models.
  We implement this by lifting the condition predicate into the relational state-space with
  construction @{term "\<lceil>b\<rceil>\<^sub><"}. \<close>

definition lift_rcond ("\<lceil>_\<rceil>\<^sub>\<leftarrow>") where
[upred_defs]: "\<lceil>b\<rceil>\<^sub>\<leftarrow> = \<lceil>b\<rceil>\<^sub><"

abbreviation
  rcond :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) urel"
  ("(3_ \<triangleleft> _ \<triangleright>\<^sub>r/ _)" [52,0,53] 52)
  where "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>\<leftarrow> \<triangleright> Q)"

text \<open> Sequential composition is heterogeneous, and simply requires that the output alphabet
  of the first matches then input alphabet of the second. We define it by lifting HOL's
  built-in relational composition operator (@{term "(O)"}). Since this returns a set, the
  definition states that the state binding $b$ is an element of this set. \<close>

lift_definition seqr::"('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<beta>, '\<gamma>) urel \<Rightarrow> ('\<alpha> \<times> '\<gamma>) upred"
is "\<lambda> P Q b. b \<in> ({p. P p} O {q. Q q})" .

adhoc_overloading
  useq seqr

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

abbreviation seqh :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" (infixr ";;\<^sub>h" 61) where
"seqh P Q \<equiv> (P ;; Q)"

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

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

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

abbreviation conv_r :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta> \<times> '\<alpha>) uexpr" ("_\<^sup>-" [999] 999)
where "conv_r e \<equiv> e \<oplus>\<^sub>p swap\<^sub>L"

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

lift_definition assigns_r :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel"
  is "\<lambda> \<sigma> (b, b'). b' = \<sigma>(b)" .

adhoc_overloading
  uassigns assigns_r

text \<open> Relational identity, or skip, is then simply an assignment with the identity substitution:
  it simply identifies all variables. \<close>

definition skip_r :: "'\<alpha> hrel" where
[urel_defs]: "skip_r = assigns_r id"

adhoc_overloading
  uskip skip_r

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

definition nd_assign :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nd_assign x = (\<Sqinter> v \<bullet> assigns_r [x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>])"

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

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

text \<open> A singleton assignment simply applies a singleton substitution function, and similarly
  for a double assignment. \<close>

abbreviation assign_r :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_r x v \<equiv> \<langle>[x \<mapsto>\<^sub>s v]\<rangle>\<^sub>a"

abbreviation assign_2_r ::
  "('t1 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t2 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t1, '\<alpha>) uexpr \<Rightarrow> ('t2, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_2_r x y u v \<equiv> assigns_r [x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]"

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

definition skip_ra :: "('\<beta>, '\<alpha>) lens \<Rightarrow>'\<alpha> hrel" where
[urel_defs]: "skip_ra v = ($v\<acute> =\<^sub>u $v)"

text \<open> Similarly, we define the alphabetised assignment operator. \<close>

definition assigns_ra :: "'\<alpha> usubst \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^bsub>_\<^esub>") where
"\<langle>\<sigma>\<rangle>\<^bsub>a\<^esub> = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> skip_ra a)"

text \<open> Assumptions ($c^{\top}$) and assertions ($c_{\bot}$) are encoded as conditionals. An assumption
  behaves like skip if the condition is true, and otherwise behaves like @{term false} (miracle).
  An assertion is the same, but yields @{term true}, which is an abort. They are the same as
  tests, as in Kleene Algebra with Tests~\<^cite>\<open>"kozen1997kleene" and "Armstrong2015"\<close>
  (KAT), which embeds a Boolean algebra into a Kleene algebra to represent conditions. \<close>

definition rassume :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "rassume c = II \<triangleleft> c \<triangleright>\<^sub>r false"

definition rassert :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "rassert c = II \<triangleleft> c \<triangleright>\<^sub>r true"

text \<open> We define two variants of while loops based on strongest and weakest fixed points. The former
  is @{term false} for an infinite loop, and the latter is @{term true}. \<close>

definition while_top :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_top b P = (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

definition while_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_bot b P = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

text \<open> While loops with invariant decoration (cf. \<^cite>\<open>"Armstrong2015"\<close>) -- partial correctness. \<close>

definition while_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "while_inv b p S = while_top b S"

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

definition while_inv_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"  where
[urel_defs]: "while_inv_bot b p S = while_bot b S"

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

definition while_vrt ::
  "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> (nat, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"  where
[urel_defs]: "while_vrt b p v S = while_bot b S"

syntax
  "_uassume"        :: "uexp \<Rightarrow> logic" ("[_]\<^sup>\<top>")
  "_uassume"        :: "uexp \<Rightarrow> logic" ("?[_]")
  "_uassert"        :: "uexp \<Rightarrow> logic" ("{_}\<^sub>\<bottom>")
  "_uwhile"         :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sup>\<top> _ do _ od")
  "_uwhile_top"     :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ do _ od")
  "_uwhile_bot"     :: "uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sub>\<bottom> _ do _ od")
  "_uwhile_inv"     :: "uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ invr _ do _ od")
  "_uwhile_inv_bot" :: "uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while\<^sub>\<bottom> _ invr _ do _ od" 71)
  "_uwhile_vrt"     :: "uexp \<Rightarrow> uexp \<Rightarrow> uexp \<Rightarrow> logic \<Rightarrow> logic" ("while _ invr _ vrt _ do _ od")

translations
  "_uassume b" == "CONST rassume b"
  "_uassert b" == "CONST rassert b"
  "_uwhile b P" == "CONST while_top b P"
  "_uwhile_top b P" == "CONST while_top b P"
  "_uwhile_bot b P" == "CONST while_bot b P"
  "_uwhile_inv b p S" == "CONST while_inv b p S"
  "_uwhile_inv_bot b p S" == "CONST while_inv_bot b p S"
  "_uwhile_vrt b p v S" == "CONST while_vrt b p v S"

text \<open> We implement a poor man's version of alphabet restriction that hides a variable within
  a relation. \<close>

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
[urel_defs]: "P \<restriction>\<^sub>\<alpha> x = (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P)"

text \<open> Alphabet extension and restriction add additional variables by the given lens in both
  their primed and unprimed versions. \<close>

definition rel_aext :: "'\<beta> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel"
where [upred_defs]: "rel_aext P a = P \<oplus>\<^sub>p (a \<times>\<^sub>L a)"

definition rel_ares :: "'\<alpha> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> hrel"
  where [upred_defs]: "rel_ares P a = (P \<restriction>\<^sub>p (a \<times> a))"

text \<open> We next describe frames and antiframes with the help of lenses. A frame states that $P$
  defines how variables in $a$ changed, and all those outside of $a$ remain the same. An
  antiframe describes the converse: all variables outside $a$ are specified by $P$, and all those in
  remain the same. For more information please see \<^cite>\<open>"Morgan90a"\<close>.\<close>

definition frame :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "frame a P = (P \<and> $\<^bold>v\<acute> =\<^sub>u $\<^bold>v \<oplus> $\<^bold>v\<acute> on &a)"

definition antiframe :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "antiframe a P = (P \<and> $\<^bold>v\<acute> =\<^sub>u $\<^bold>v\<acute> \<oplus> $\<^bold>v on &a)"

text \<open> Frame extension combines alphabet extension with the frame operator to both add additional
  variables and then frame those. \<close>

definition rel_frext :: "('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> hrel \<Rightarrow> '\<alpha> hrel"  where
[upred_defs]: "rel_frext a P = frame a (rel_aext P a)"

text \<open> The nameset operator can be used to hide a portion of the after-state that lies outside
  the lens $a$. It can be useful to partition a relation's variables in order to conjoin it
  with another relation. \<close>

definition nameset :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nameset a P = (P \<restriction>\<^sub>v {$\<^bold>v,$a\<acute>})"

subsection \<open> Syntax Translations \<close>

syntax
  \<comment> \<open> Alternative traditional conditional syntax \<close>
  "_utp_if" :: "uexp \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(if\<^sub>u (_)/ then (_)/ else (_))" [0, 0, 71] 71)
  \<comment> \<open> Iterated sequential composition \<close>
  "_seqr_iter" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> '\<sigma> hrel \<Rightarrow> '\<sigma> hrel" ("(3;; _ : _ \<bullet>/ _)" [0, 0, 10] 10)
  \<comment> \<open> Single and multiple assignement \<close>
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  ("'(_') := '(_')")
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  (infixr ":=" 62)
  \<comment> \<open> Non-deterministic assignment \<close>
  "_nd_assign" :: "svids \<Rightarrow> logic" ("_ := *" [62] 62)
  \<comment> \<open> Substitution constructor \<close>
  "_mk_usubst"      :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"
  \<comment> \<open> Alphabetised skip \<close>
  "_skip_ra"        :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")
  \<comment> \<open> Frame \<close>
  "_frame"          :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]" [99,0] 100)
  \<comment> \<open> Antiframe \<close>
  "_antiframe"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:\<lbrakk>_\<rbrakk>" [79,0] 80)
  \<comment> \<open> Relational Alphabet Extension \<close>
  "_rel_aext"  :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<oplus>\<^sub>r" 90)
  \<comment> \<open> Relational Alphabet Restriction \<close>
  "_rel_ares"  :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>r" 90)
  \<comment> \<open> Frame Extension \<close>
  "_rel_frext" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sup>+" [99,0] 100)
  \<comment> \<open> Nameset \<close>
  "_nameset"        :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("ns _ \<bullet> _" [0,999] 999)

translations
  "_utp_if b P Q" => "P \<triangleleft> b \<triangleright>\<^sub>r Q"
  ";; x : l \<bullet> P" \<rightleftharpoons> "(CONST seqr_iter) l (\<lambda>x. P)"
  "_mk_usubst \<sigma> (_svid_unit x) v" \<rightleftharpoons> "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" \<rightleftharpoons> "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST uassigns (_mk_usubst (CONST id) xs vs)"
  "_assignment x v" <= "CONST uassigns (CONST subst_upd (CONST id) x v)"
  "_assignment x v" <= "_assignment (_spvar x) v"
  "_nd_assign x" => "CONST nd_assign (_mk_svid_list x)"
  "_nd_assign x" <= "CONST nd_assign x"
  "x,y := u,v" <= "CONST uassigns (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"
  "_skip_ra v" \<rightleftharpoons> "CONST skip_ra v"
  "_frame x P" => "CONST frame x P"
  "_frame (_salphaset (_salphamk x)) P" <= "CONST frame x P"
  "_antiframe x P" => "CONST antiframe x P"
  "_antiframe (_salphaset (_salphamk x)) P" <= "CONST antiframe x P"
  "_nameset x P" == "CONST nameset x P"
  "_rel_aext P a" == "CONST rel_aext P a"
  "_rel_ares P a" == "CONST rel_ares P a"
  "_rel_frext a P" == "CONST rel_frext a P"

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

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

translations
  (type) "'\<alpha> hrel" <= (type) "(bool, '\<alpha>) hexpr"

subsection \<open> Relation Properties \<close>

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

definition ufunctional :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "ufunctional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"

definition uinj :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "uinj R \<longleftrightarrow> II \<sqsubseteq> R ;; R\<^sup>-"

definition Dom :: "'\<alpha> hrel \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "Dom P = \<lfloor>\<exists> $\<^bold>v\<acute> \<bullet> P\<rfloor>\<^sub><"

definition Ran :: "'\<alpha> hrel \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "Ran P = \<lfloor>\<exists> $\<^bold>v \<bullet> P\<rfloor>\<^sub>>"

\<comment> \<open> Configuration for UTP tactics. \<close>

update_uexpr_rep_eq_thms \<comment> \<open> Reread @{text rep_eq} theorems. \<close>

subsection \<open> Introduction laws \<close>

lemma urel_refine_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<sqsubseteq> Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P \<sqsubseteq> Q"
  by (rel_auto)

lemma urel_eq_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> = Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_iuvar [unrest]: "out\<alpha> \<sharp> $x"
  by (metis fst_snd_lens_indep lift_pre_var out\<alpha>_def unrest_aext_indep)

lemma unrest_ouvar [unrest]: "in\<alpha> \<sharp> $x\<acute>"
  by (metis in\<alpha>_def lift_post_var snd_fst_lens_indep unrest_aext_indep)

lemma unrest_semir_undash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x \<sharp> P"
  shows "$x \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_semir_dash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x\<acute> \<sharp> Q"
  shows "$x\<acute> \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_cond [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> b; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<triangleleft> b \<triangleright> Q"
  by (rel_auto)

lemma unrest_lift_rcond [unrest]:
  "x \<sharp> \<lceil>b\<rceil>\<^sub>< \<Longrightarrow> x \<sharp> \<lceil>b\<rceil>\<^sub>\<leftarrow>"
  by (simp add: lift_rcond_def)

lemma unrest_in\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; in\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x \<sharp> P"
  by (rel_auto)

lemma unrest_out\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; out\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (rel_auto)

lemma unrest_pre_out\<alpha> [unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def)

lemma unrest_post_in\<alpha> [unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def)

lemma unrest_pre_in_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x \<sharp> \<lceil>p1\<rceil>\<^sub><"
  by (transfer, simp)

lemma unrest_post_out_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x\<acute> \<sharp> \<lceil>p1\<rceil>\<^sub>>"
  by (transfer, simp)

lemma unrest_convr_out\<alpha> [unrest]:
  "in\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_convr_in\<alpha> [unrest]:
  "out\<alpha> \<sharp> p \<Longrightarrow> in\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_alpha_usubst_rel_lift [unrest]:
  "out\<alpha> \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>s"
  by (rel_auto)

lemma unrest_in_rel_aext [unrest]: "x \<bowtie> y \<Longrightarrow> $y \<sharp> P \<oplus>\<^sub>r x"
  by (simp add: rel_aext_def unrest_aext_indep)

lemma unrest_out_rel_aext [unrest]: "x \<bowtie> y \<Longrightarrow> $y\<acute> \<sharp> P \<oplus>\<^sub>r x"
  by (simp add: rel_aext_def unrest_aext_indep)

lemma rel_aext_false [alpha]:
  "false \<oplus>\<^sub>r a = false"
  by (pred_auto)

lemma rel_aext_seq [alpha]:
  "weak_lens a \<Longrightarrow> (P ;; Q) \<oplus>\<^sub>r a = (P \<oplus>\<^sub>r a ;; Q \<oplus>\<^sub>r a)"
  apply (rel_auto)
  apply (rename_tac aa b y)
  apply (rule_tac x="create\<^bsub>a\<^esub> y" in exI)
  apply (simp)
  done

lemma rel_aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<oplus>\<^sub>r a = (P \<oplus>\<^sub>r a \<triangleleft> b \<oplus>\<^sub>p a \<triangleright>\<^sub>r Q \<oplus>\<^sub>r a)"
  by (rel_auto)

subsection \<open> Substitution laws \<close>

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

text \<open> The following laws support substitution in heterogeneous relations for polymorphically
  typed literal expressions. These cannot be supported more generically due to limitations
  in HOL's type system. The laws are presented in a slightly strange way so as to be as
  general as possible. \<close>

lemma bool_seqr_laws [usubst]:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma zero_one_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>0/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>1/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>0/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>1/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma numeral_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>numeral n/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>numeral n/$x\<acute>\<rbrakk>)"
  by (rel_auto)+

lemma usubst_condr [usubst]:
  "\<sigma> \<dagger> (P \<triangleleft> b \<triangleright> Q) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> b \<triangleright> \<sigma> \<dagger> Q)"
  by (rel_auto)

lemma subst_skip_r [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> II = \<langle>\<lfloor>\<sigma>\<rfloor>\<^sub>s\<rangle>\<^sub>a"
  by (rel_simp, (metis (mono_tags, lifting) prod.sel(1) sndI surjective_pairing)+)

lemma subst_pre_skip [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II = \<langle>\<sigma>\<rangle>\<^sub>a"
  by (rel_auto)

lemma subst_rel_lift_seq [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> (P ;; Q) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P) ;; Q"
  by (rel_auto)

lemma subst_rel_lift_comp [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<circ> \<lceil>\<rho>\<rceil>\<^sub>s = \<lceil>\<sigma> \<circ> \<rho>\<rceil>\<^sub>s"
  by (rel_auto)

lemma usubst_upd_in_comp [usubst]:
  "\<sigma>(&in\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma usubst_upd_out_comp [usubst]:
  "\<sigma>(&out\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x\<acute> \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def out\<alpha>_def out_var_def snd_lens_def)

lemma subst_lift_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lceil>\<sigma>(x \<mapsto>\<^sub>s v)\<rceil>\<^sub>s = \<lceil>\<sigma>\<rceil>\<^sub>s($x \<mapsto>\<^sub>s \<lceil>v\<rceil>\<^sub><)"
  by (simp add: alpha usubst, simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma subst_drop_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lfloor>\<sigma>($x \<mapsto>\<^sub>s v)\<rfloor>\<^sub>s = \<lfloor>\<sigma>\<rfloor>\<^sub>s(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub><)"
  by pred_simp

lemma subst_lift_pre [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>b\<rceil>\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub><"
  by (metis apply_subst_ext fst_vwb_lens in\<alpha>_def)

lemma unrest_usubst_lift_in [unrest]:
  "x \<sharp> P \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma unrest_usubst_lift_out [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma subst_lift_cond [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>s\<rceil>\<^sub>\<leftarrow> = \<lceil>\<sigma> \<dagger> s\<rceil>\<^sub>\<leftarrow>"
  by (rel_auto)

lemma msubst_seq [usubst]: "(P(x) ;; Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> ;; (Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk>)"
  by (rel_auto)

subsection \<open> Alphabet laws \<close>

lemma aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright> Q) \<oplus>\<^sub>p a = ((P \<oplus>\<^sub>p a) \<triangleleft> (b \<oplus>\<^sub>p a) \<triangleright> (Q \<oplus>\<^sub>p a))"
  by (rel_auto)

lemma aext_seq [alpha]:
  "wb_lens a \<Longrightarrow> ((P ;; Q) \<oplus>\<^sub>p (a \<times>\<^sub>L a)) = ((P \<oplus>\<^sub>p (a \<times>\<^sub>L a)) ;; (Q \<oplus>\<^sub>p (a \<times>\<^sub>L a)))"
  by (rel_simp, metis wb_lens_weak weak_lens.put_get)

lemma rcond_lift_true [simp]:
  "\<lceil>true\<rceil>\<^sub>\<leftarrow> = true"
  by rel_auto

lemma rcond_lift_false [simp]:
  "\<lceil>false\<rceil>\<^sub>\<leftarrow> = false"
  by rel_auto

lemma rel_ares_aext [alpha]:
  "vwb_lens a \<Longrightarrow> (P \<oplus>\<^sub>r a) \<restriction>\<^sub>r a = P"
  by (rel_auto)

lemma rel_aext_ares [alpha]:
  "{$a, $a\<acute>} \<natural> P \<Longrightarrow> P \<restriction>\<^sub>r a \<oplus>\<^sub>r a = P"
  by (rel_auto)

lemma rel_aext_uses [unrest]:
  "vwb_lens a \<Longrightarrow> {$a, $a\<acute>} \<natural> (P \<oplus>\<^sub>r a)"
  by (rel_auto)

subsection \<open> Relational unrestriction \<close>

text \<open> Relational unrestriction states that a variable is both unchanged by a relation, and is
  not "read" by the relation. \<close>

definition RID :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"
where "RID x P = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x)"

declare RID_def [urel_defs]

lemma RID1: "vwb_lens x \<Longrightarrow> (\<forall> v. x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>) \<Longrightarrow> RID(x)(P) = P"
  apply (rel_auto)
   apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
  done

lemma RID2: "vwb_lens x \<Longrightarrow> x := \<guillemotleft>v\<guillemotright> ;; RID(x)(P) = RID(x)(P) ;; x := \<guillemotleft>v\<guillemotright>"
  apply (rel_auto)
   apply (metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put wb_lens_def weak_lens.put_get)
  apply blast
  done

lemma RID_assign_commute:
  "vwb_lens x \<Longrightarrow> P = RID(x)(P) \<longleftrightarrow> (\<forall> v. x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>)"
  by (metis RID1 RID2)

lemma RID_idem:
  "mwb_lens x \<Longrightarrow> RID(x)(RID(x)(P)) = RID(x)(P)"
  by (rel_auto)

lemma RID_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> RID(x)(P) \<sqsubseteq> RID(x)(Q)"
  by (rel_auto)

lemma RID_pr_var [simp]:
  "RID (pr_var x) = RID x"
  by (simp add: pr_var_def)

lemma RID_skip_r:
  "vwb_lens x \<Longrightarrow> RID(x)(II) = II"
  apply (rel_auto) using vwb_lens.put_eq by fastforce

lemma skip_r_RID [closure]: "vwb_lens x \<Longrightarrow> II is RID(x)"
  by (simp add: Healthy_def RID_skip_r)

lemma RID_disj:
  "RID(x)(P \<or> Q) = (RID(x)(P) \<or> RID(x)(Q))"
  by (rel_auto)

lemma disj_RID [closure]: "\<lbrakk> P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> (P \<or> Q) is RID(x)"
  by (simp add: Healthy_def RID_disj)

lemma RID_conj:
  "vwb_lens x \<Longrightarrow> RID(x)(RID(x)(P) \<and> RID(x)(Q)) = (RID(x)(P) \<and> RID(x)(Q))"
  by (rel_auto)

lemma conj_RID [closure]: "\<lbrakk> vwb_lens x; P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> (P \<and> Q) is RID(x)"
  by (metis Healthy_if Healthy_intro RID_conj)

lemma RID_assigns_r_diff:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> RID(x)(\<langle>\<sigma>\<rangle>\<^sub>a) = \<langle>\<sigma>\<rangle>\<^sub>a"
  apply (rel_auto)
   apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
  done

lemma assigns_r_RID [closure]: "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>a is RID(x)"
  by (simp add: Healthy_def RID_assigns_r_diff)

lemma RID_assign_r_same:
  "vwb_lens x \<Longrightarrow> RID(x)(x := v) = II"
  apply (rel_auto)
  using vwb_lens.put_eq apply fastforce
  done

lemma RID_seq_left:
  assumes "vwb_lens x"
  shows "RID(x)(RID(x)(P) ;; Q) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(RID(x)(P) ;; Q) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; Q) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> (\<exists> $x \<bullet> $x\<acute> =\<^sub>u $x)) ;; (\<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
     apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
    done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma RID_seq_right:
  assumes "vwb_lens x"
  shows "RID(x)(P ;; RID(x)(Q)) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(P ;; RID(x)(Q)) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = (((\<exists> $x \<bullet>  P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> (\<exists> $x\<acute> \<bullet> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
     apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
    done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp robust, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma seqr_RID_closed [closure]: "\<lbrakk> vwb_lens x; P is RID(x); Q is RID(x) \<rbrakk> \<Longrightarrow> P ;; Q is RID(x)"
  by (metis Healthy_def RID_seq_right)

definition unrest_relation :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> bool" (infix "\<sharp>\<sharp>" 20)
where "(x \<sharp>\<sharp> P) \<longleftrightarrow> (P is RID(x))"

declare unrest_relation_def [urel_defs]

lemma runrest_assign_commute:
  "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P \<rbrakk> \<Longrightarrow> x := \<guillemotleft>v\<guillemotright> ;; P = P ;; x := \<guillemotleft>v\<guillemotright>"
  by (metis RID2 Healthy_def unrest_relation_def)

lemma runrest_ident_var:
  assumes "x \<sharp>\<sharp> P"
  shows "($x \<and> P) = (P \<and> $x\<acute>)"
proof -
  have "P = ($x\<acute> =\<^sub>u $x \<and> P)"
    by (metis RID_def assms Healthy_def unrest_relation_def utp_pred_laws.inf.cobounded2 utp_pred_laws.inf_absorb2)
  moreover have "($x\<acute> =\<^sub>u $x \<and> ($x \<and> P)) = ($x\<acute> =\<^sub>u $x \<and> (P \<and> $x\<acute>))"
    by (rel_auto)
  ultimately show ?thesis
    by (metis utp_pred_laws.inf.assoc utp_pred_laws.inf_left_commute)
qed

lemma skip_r_runrest [unrest]:
  "vwb_lens x \<Longrightarrow> x \<sharp>\<sharp> II"
  by (simp add: unrest_relation_def closure)

lemma assigns_r_runrest:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: unrest_relation_def closure)

lemma seq_r_runrest [unrest]:
  assumes "vwb_lens x" "x \<sharp>\<sharp> P" "x \<sharp>\<sharp> Q"
  shows "x \<sharp>\<sharp> (P ;; Q)"
  using assms by (simp add: unrest_relation_def closure )

lemma false_runrest [unrest]: "x \<sharp>\<sharp> false"
  by (rel_auto)

lemma and_runrest [unrest]: "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<and> Q)"
  by (metis RID_conj Healthy_def unrest_relation_def)

lemma or_runrest [unrest]: "\<lbrakk> x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<or> Q)"
  by (simp add: RID_disj Healthy_def unrest_relation_def)

end


theory PreferenceLogicCeterisParibus (** Benzmüller & Fuenmayor, 2020 **)
  imports PreferenceLogicBasics
begin (** Ceteris Paribus reasoning by van Benthem et al, JPL 2009 **)

(*Section 5: Equality-based Ceteris Paribus Preference Logic*)
abbreviation a1::"\<sigma>\<Rightarrow>\<pi>\<Rightarrow>bool" ("_\<^bold>\<in>_") where "\<phi> \<^bold>\<in> \<Gamma> \<equiv> \<Gamma> \<phi>"
abbreviation a2 ("_\<^bold>\<subseteq>_") where "\<Gamma> \<^bold>\<subseteq> \<Gamma>' \<equiv> \<forall>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a3 ("_\<^bold>\<union>_") where "\<Gamma> \<^bold>\<union> \<Gamma>' \<equiv> \<lambda>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<or> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a4 ("_\<^bold>\<inter>_") where "\<Gamma> \<^bold>\<inter> \<Gamma>' \<equiv> \<lambda>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<and> \<phi> \<^bold>\<in> \<Gamma>'"
abbreviation a5 ("\<^bold>{_\<^bold>}") where "\<^bold>{\<phi>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<phi>"
abbreviation a6 ("\<^bold>{_,_\<^bold>}")   where "\<^bold>{\<alpha>,\<beta>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<alpha> \<or> x=\<beta>"
abbreviation a7 ("\<^bold>{_,_,_\<^bold>}") where "\<^bold>{\<alpha>,\<beta>,\<gamma>\<^bold>} \<equiv> \<lambda>x::\<sigma>. x=\<alpha> \<or> x=\<beta> \<or> x=\<gamma>"
abbreviation a8 ("\<^bold>\<emptyset>")   where "\<^bold>\<emptyset> \<equiv> (\<lambda>\<psi>::\<sigma>. False)"
abbreviation a9 ("\<^bold>\<U>")   where "\<^bold>\<U> \<equiv> (\<lambda>\<psi>::\<sigma>. True)"

abbreviation c14 ("_\<^bold>\<equiv>\<^sub>__") where "w \<^bold>\<equiv>\<^sub>\<Gamma> v \<equiv> \<forall>\<phi>. \<phi> \<^bold>\<in> \<Gamma> \<longrightarrow> (\<phi> w \<longleftrightarrow> \<phi> v)"
abbreviation c15 ("_\<^bold>\<unlhd>\<^sub>__") where "w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<equiv> w \<preceq> v \<and> w \<^bold>\<equiv>\<^sub>\<Gamma> v"
abbreviation c16 ("_\<^bold>\<lhd>\<^sub>__") where "w \<^bold>\<lhd>\<^sub>\<Gamma> v \<equiv> w \<prec> v \<and> w \<^bold>\<equiv>\<^sub>\<Gamma> v"
abbreviation c17 ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sup>\<preceq>_") where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c18 ("[_]\<^sup>\<preceq>_") where "[\<Gamma>]\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<unlhd>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"
abbreviation c19 ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sup>\<prec>_") where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<lhd>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c20 ("[_]\<^sup>\<prec>_") where "[\<Gamma>]\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<lhd>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"
abbreviation c21 ("\<^bold>\<langle>_\<^bold>\<rangle>_")  where "\<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<phi> \<equiv> \<lambda>w.\<exists>v. w \<^bold>\<equiv>\<^sub>\<Gamma> v \<and> \<phi> v"
abbreviation c22 ("[_]_")  where "[\<Gamma>]\<phi> \<equiv> \<lambda>w.\<forall>v. w \<^bold>\<equiv>\<^sub>\<Gamma> v \<longrightarrow> \<phi> v"

(*Section 6: Ceteris Paribus Counterparts of Binary Pref. Statements*)
(*operators below not defined in paper; existence is tacitly suggested.
  AA-variant draws upon von Wright's. AE-variant draws upon Halpern's.*)
abbreviation C23 ("_\<prec>\<^sub>A\<^sub>A\<^sup>__")
  where "(\<phi> \<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<forall>t. \<phi> s \<and> \<psi> t \<longrightarrow> s \<^bold>\<lhd>\<^sub>\<Gamma> t"
abbreviation c24 ("_\<preceq>\<^sub>A\<^sub>A\<^sup>__")
  where "(\<phi> \<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<forall>t. \<phi> s \<and> \<psi> t \<longrightarrow> s \<^bold>\<unlhd>\<^sub>\<Gamma> t"
abbreviation c25 ("_\<prec>\<^sub>A\<^sub>E\<^sup>__")
  where "(\<phi> \<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<exists>t. \<phi> s \<longrightarrow> \<psi> t \<and> s \<^bold>\<lhd>\<^sub>\<Gamma> t"
abbreviation c26 ("_\<preceq>\<^sub>A\<^sub>E\<^sup>__")
  where "(\<phi> \<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi>) u \<equiv> \<forall>s.\<exists>t. \<phi> s \<longrightarrow> \<psi> t \<and> s \<^bold>\<unlhd>\<^sub>\<Gamma> t"
abbreviation c27 ("_\<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>__") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> [\<Gamma>]\<^sup>\<preceq>\<^bold>\<not>\<phi>)"
abbreviation c28 ("_\<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>__") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> [\<Gamma>]\<^sup>\<prec>\<^bold>\<not>\<phi>)"
abbreviation c29 ("_\<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>__") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<prec>\<psi>)"
abbreviation c30 ("_\<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>__") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E\<^sup>\<Gamma> \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<langle>\<Gamma>\<^bold>\<rangle>\<^sup>\<preceq>\<psi>)"

(*Consistency confirmed (trivial: only abbreviations are introduced*)
lemma True nitpick[satisfy,user_axioms] oops
end

(*Lines 80--92: Except for $<^\Gamma$, the operators defined here are not
explicitly defined in the paper, but their existence is tacitly suggested.
$<^\Gamma$ aims at modelling von Wright's notion of ceteris paribus (``all
other things being equal'') preferences wrt. a set of formulas $\Gamma$
and it corresponds to $<_{AA}^\Sigma$ below, where $\Sigma=cp(\Gamma)$,
i.e., $\Sigma$ are the propositional atoms independent from (not occurring
in)  $\Gamma$, they are to be elicited by extra-logical means. Our variants
below can thus be understood as "these (given) things being equal"-preferences.*)


(*  Title:      HOL/ATP.thy
    Author:     Fabian Immler, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
*)

section \<open>Automatic Theorem Provers (ATPs)\<close>

theory ATP
imports Meson
begin

subsection \<open>ATP problems and proofs\<close>

ML_file "Tools/ATP/atp_util.ML"
ML_file "Tools/ATP/atp_problem.ML"
ML_file "Tools/ATP/atp_proof.ML"
ML_file "Tools/ATP/atp_proof_redirect.ML"
ML_file "Tools/ATP/atp_satallax.ML"

subsection \<open>Higher-order reasoning helpers\<close>

definition fFalse :: bool where
"fFalse \<longleftrightarrow> False"

definition fTrue :: bool where
"fTrue \<longleftrightarrow> True"

definition fNot :: "bool \<Rightarrow> bool" where
"fNot P \<longleftrightarrow> \<not> P"

definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"fComp P = (\<lambda>x. \<not> P x)"

definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fconj P Q \<longleftrightarrow> P \<and> Q"

definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fdisj P Q \<longleftrightarrow> P \<or> Q"

definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"

definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fAll P \<longleftrightarrow> All P"

definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fEx P \<longleftrightarrow> Ex P"

definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"fequal x y \<longleftrightarrow> (x = y)"

lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
unfolding fFalse_def fTrue_def by simp

lemma fNot_table:
"fNot fFalse = fTrue"
"fNot fTrue = fFalse"
unfolding fFalse_def fTrue_def fNot_def by auto

lemma fconj_table:
"fconj fFalse P = fFalse"
"fconj P fFalse = fFalse"
"fconj fTrue fTrue = fTrue"
unfolding fFalse_def fTrue_def fconj_def by auto

lemma fdisj_table:
"fdisj fTrue P = fTrue"
"fdisj P fTrue = fTrue"
"fdisj fFalse fFalse = fFalse"
unfolding fFalse_def fTrue_def fdisj_def by auto

lemma fimplies_table:
"fimplies P fTrue = fTrue"
"fimplies fFalse P = fTrue"
"fimplies fTrue fFalse = fFalse"
unfolding fFalse_def fTrue_def fimplies_def by auto

lemma fAll_table:
"Ex (fComp P) \<or> fAll P = fTrue"
"All P \<or> fAll P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fAll_def by auto

lemma fEx_table:
"All (fComp P) \<or> fEx P = fTrue"
"Ex P \<or> fEx P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fEx_def by auto

lemma fequal_table:
"fequal x x = fTrue"
"x = y \<or> fequal x y = fFalse"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fNot_law:
"fNot P \<noteq> P"
unfolding fNot_def by auto

lemma fComp_law:
"fComp P x \<longleftrightarrow> \<not> P x"
unfolding fComp_def ..

lemma fconj_laws:
"fconj P P \<longleftrightarrow> P"
"fconj P Q \<longleftrightarrow> fconj Q P"
"fNot (fconj P Q) \<longleftrightarrow> fdisj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fdisj_laws:
"fdisj P P \<longleftrightarrow> P"
"fdisj P Q \<longleftrightarrow> fdisj Q P"
"fNot (fdisj P Q) \<longleftrightarrow> fconj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fimplies_laws:
"fimplies P Q \<longleftrightarrow> fdisj (\<not> P) Q"
"fNot (fimplies P Q) \<longleftrightarrow> fconj P (fNot Q)"
unfolding fNot_def fconj_def fdisj_def fimplies_def by auto

lemma fAll_law:
"fNot (fAll R) \<longleftrightarrow> fEx (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fEx_law:
"fNot (fEx R) \<longleftrightarrow> fAll (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fequal_laws:
"fequal x y = fequal y x"
"fequal x y = fFalse \<or> fequal y z = fFalse \<or> fequal x z = fTrue"
"fequal x y = fFalse \<or> fequal (f x) (f y) = fTrue"
unfolding fFalse_def fTrue_def fequal_def by auto

subsection \<open>Waldmeister helpers\<close>

(* Has all needed simplification lemmas for logic. *)
lemma boolean_equality: "(P \<longleftrightarrow> P) = True"
  by simp

lemma boolean_comm: "(P \<longleftrightarrow> Q) = (Q \<longleftrightarrow> P)"
  by auto

lemmas waldmeister_fol = boolean_equality boolean_comm
  simp_thms(1-5,7-8,11-25,27-33) disj_comms disj_assoc conj_comms conj_assoc

subsection \<open>Basic connection between ATPs and HOL\<close>

ML_file "Tools/lambda_lifting.ML"
ML_file "Tools/monomorph.ML"
ML_file "Tools/ATP/atp_problem_generate.ML"
ML_file "Tools/ATP/atp_proof_reconstruct.ML"
ML_file "Tools/ATP/atp_systems.ML"
ML_file "Tools/ATP/atp_waldmeister.ML"

hide_fact (open) waldmeister_fol boolean_equality boolean_comm

end