(*  Title:      E-Abstraction/Petri_Net.thy
    Author:     Nicolas Amat
*)

section \<open>Petri Net Formalization\<close>

text \<open>This section contains Petri nets formalization\<close>

theory Petri_Net
  imports
  "HOL-Library.Function_Algebras"
begin

subsection \<open>Markings\<close>

typedef ('pl) markings = "{(m::'pl \<Rightarrow> nat). True}"
  by simp

subsection \<open>Labelling Functions\<close>

typedef ('tr,'lb) labellings = "{(l::'tr \<Rightarrow> 'lb option). True}"
  by simp

subsection \<open>Petri Nets\<close>

record ('pl,'tr,'lb) petri_net =
  P :: "'pl set"
  T :: "'tr set"
  Pre :: "'tr \<Rightarrow> 'pl \<Rightarrow> nat"
  Post :: "'tr \<Rightarrow> 'pl \<Rightarrow> nat"
  m0 :: "('pl) markings"
  l :: "('tr,'lb) labellings"

subsection \<open>Behavior\<close>

definition transition_enabled :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> 'tr \<Rightarrow> bool" where
  "transition_enabled pn m tr \<equiv> (Rep_markings m) \<ge> (Pre pn tr)"

definition resulting_marking_firing_transition :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> 'tr \<Rightarrow> ('pl) markings" where
  "resulting_marking_firing_transition pn m tr \<equiv> Abs_markings ((Rep_markings m) - (Pre pn tr) + (Post pn tr))"

subsection \<open>Firing Sequence\<close>

fun firing_sequence :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> 'tr list \<Rightarrow> bool" where
  "firing_sequence pn m [] = True" |
  "firing_sequence pn m (tr#seq) = ((transition_enabled pn m tr) \<and> (firing_sequence pn (resulting_marking_firing_transition pn m tr) seq))"

fun resulting_marking_firing_sequence :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> 'tr list \<Rightarrow> ('pl) markings" where
  "resulting_marking_firing_sequence pn m [] = m" |
  "resulting_marking_firing_sequence pn m (tr#seq) = resulting_marking_firing_sequence pn (resulting_marking_firing_transition pn m tr) seq"

subsection \<open>Reachable Markings\<close>

definition reachable_marking :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> bool" where
  "reachable_marking pn m \<equiv> \<exists>seq. (firing_sequence pn (m0 pn) seq) \<and> (resulting_marking_firing_sequence pn (m0 pn) seq = m)"

definition set_reachable_markings :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings set" where
"set_reachable_markings pn = {m. reachable_marking pn m}"

lemma init_reachable_marking:
  fixes pn::"('pl,'tr,'lb) petri_net"
  shows "reachable_marking pn (m0 pn)"
  using firing_sequence.simps(1) reachable_marking_def resulting_marking_firing_sequence.simps(1) by blast

subsection \<open>Pre and Post Sets\<close>

definition transition_pre_set :: "('pl,'tr,'lb) petri_net \<Rightarrow> 'tr \<Rightarrow> 'pl set" where
  "transition_pre_set pn tr \<equiv> {pl. Pre pn tr pl > 0}"

definition transition_post_set :: "('pl,'tr,'lb) petri_net \<Rightarrow> 'tr \<Rightarrow> 'pl set" where
  "transition_post_set pn tr \<equiv> {pl. Post pn tr pl > 0}"

definition place_pre_set :: "('pl,'tr,'lb) petri_net \<Rightarrow> 'pl \<Rightarrow> 'tr set" where
  "place_pre_set pn pl \<equiv> {tr. Post pn tr pl > 0}"

definition place_post_set :: "('pl,'tr,'lb) petri_net \<Rightarrow> 'pl \<Rightarrow> 'tr set" where
  "place_post_set pn pl \<equiv> {tr. Pre pn tr pl > 0}"

subsection \<open>Observable Sequence\<close>

fun observable_sequence :: "('tr,'lb) labellings \<Rightarrow> 'tr list \<Rightarrow> 'lb option list" where
  "observable_sequence lb [] = []" |
  "observable_sequence lb (tr#seq) = ((Rep_labellings lb tr)#(observable_sequence lb seq))"

fun similar_observable_sequences :: "'lb option list \<Rightarrow> 'lb option list \<Rightarrow> bool" where
  "similar_observable_sequences [] [] = True" |
  "similar_observable_sequences (Some l1#seq1) (Some l2#seq2) = ((l1 = l2) \<and> (similar_observable_sequences seq1 seq2))" |
  "similar_observable_sequences (Some l1#seq1) [] = False" |
  "similar_observable_sequences [] (Some l2#seq2) = False" |
  "similar_observable_sequences (None#seq1) seq2 = similar_observable_sequences seq1 seq2" |
  "similar_observable_sequences seq1 (None#seq2) = similar_observable_sequences seq1 seq2"

subsection \<open>Compatible Markings\<close>

definition compatible_markings :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> bool" where
  "compatible_markings N1 m1 N2 m2 \<equiv> \<forall>p \<in> (P N1) \<inter> (P N2). (Rep_markings m1 p) = (Rep_markings m2 p)"

subsection \<open>Abstraction\<close>

typedef ('pl,'add_var) system_equations = "{(E::'add_var list \<Rightarrow> ('pl) markings \<Rightarrow> ('pl) markings \<Rightarrow> bool). True}"
  by simp

record ('pl,'add_var) abstraction =
  add_vars :: "'add_var list"
  system :: "('pl,'add_var) system_equations"

definition abstraction_model :: "('pl,'add_var) abstraction \<Rightarrow>  ('pl) markings \<Rightarrow> ('pl) markings \<Rightarrow> bool" where
  "abstraction_model E m1 m2 \<equiv> (Rep_system_equations (system E)) (add_vars E) m1 m2"

definition solvable :: "('pl,'add_var) abstraction \<Rightarrow> bool" where
  "solvable E \<equiv> (\<forall>m1. \<exists>m2. abstraction_model E m1 m2)
              \<and> (\<forall>m2. \<exists>m1. abstraction_model E m1 m2)"

subsection \<open>Markings Compatible With Abstraction\<close>

definition markings_compatible_with_abstraction :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> ('pl,'add_var) abstraction \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> ('pl) markings \<Rightarrow> bool" where
  "markings_compatible_with_abstraction N1 m1 E N2 m2 \<equiv> (compatible_markings N1 m1 N2 m2) \<and> (abstraction_model E m1 m2)"

subsection \<open>E-Abstraction\<close>

definition initial_markings_cond :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl,'add_var) abstraction \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> bool" where
  "initial_markings_cond N1 E N2 \<equiv> markings_compatible_with_abstraction N1 (m0 N1) E N2 (m0 N2)"

definition observable_sequences_cond :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl,'add_var) abstraction \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> bool" where
  "observable_sequences_cond N1 E N2 \<equiv>
    \<forall>tr1. (firing_sequence N1 (m0 N1) tr1)
    \<longrightarrow> (\<forall>m2. (markings_compatible_with_abstraction N1 (resulting_marking_firing_sequence N1 (m0 N1) tr1) E N2 m2)
        \<longrightarrow> (\<exists>tr2. (m2 = resulting_marking_firing_sequence N2 (m0 N2) tr2) \<and> (similar_observable_sequences (observable_sequence (l N1) tr1) (observable_sequence (l N2) tr2))))"

definition E_abstraction :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl,'add_var) abstraction \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> bool" where
  "E_abstraction N1 E N2 \<equiv> (initial_markings_cond N1 E N2) \<and> (observable_sequences_cond  N1 E N2)"

definition E_abstraction_equivalence :: "('pl,'tr,'lb) petri_net \<Rightarrow> ('pl,'ad_var) abstraction  \<Rightarrow> ('pl,'tr,'lb) petri_net \<Rightarrow> bool" where
  "E_abstraction_equivalence N1 E N2 \<equiv> (E_abstraction N1 E N2) \<and>  (E_abstraction N2 E N1)"

end


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

section \<open>Numeric types for code generation onto target language numerals only\<close>

theory Code_Numeral
imports Nat_Transfer Divides Lifting
begin

subsection \<open>Type of target language integers\<close>

typedef integer = "UNIV :: int set"
  morphisms int_of_integer integer_of_int ..

setup_lifting type_definition_integer

lemma integer_eq_iff:
  "k = l \<longleftrightarrow> int_of_integer k = int_of_integer l"
  by transfer rule

lemma integer_eqI:
  "int_of_integer k = int_of_integer l \<Longrightarrow> k = l"
  using integer_eq_iff [of k l] by simp

lemma int_of_integer_integer_of_int [simp]:
  "int_of_integer (integer_of_int k) = k"
  by transfer rule

lemma integer_of_int_int_of_integer [simp]:
  "integer_of_int (int_of_integer k) = k"
  by transfer rule

instantiation integer :: ring_1
begin

lift_definition zero_integer :: integer
  is "0 :: int"
  .

declare zero_integer.rep_eq [simp]

lift_definition one_integer :: integer
  is "1 :: int"
  .

declare one_integer.rep_eq [simp]

lift_definition plus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "plus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare plus_integer.rep_eq [simp]

lift_definition uminus_integer :: "integer \<Rightarrow> integer"
  is "uminus :: int \<Rightarrow> int"
  .

declare uminus_integer.rep_eq [simp]

lift_definition minus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "minus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare minus_integer.rep_eq [simp]

lift_definition times_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "times :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare times_integer.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

instance integer :: Rings.dvd ..

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (of_nat :: nat \<Rightarrow> int) (of_nat :: nat \<Rightarrow> integer)"
  by (rule transfer_rule_of_nat) transfer_prover+

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (\<lambda>k :: int. k :: int) (of_int :: int \<Rightarrow> integer)"
proof -
  have "rel_fun HOL.eq pcr_integer (of_int :: int \<Rightarrow> int) (of_int :: int \<Rightarrow> integer)"
    by (rule transfer_rule_of_int) transfer_prover+
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (numeral :: num \<Rightarrow> int) (numeral :: num \<Rightarrow> integer)"
  by (rule transfer_rule_numeral) transfer_prover+

lemma [transfer_rule]:
  "rel_fun HOL.eq (rel_fun HOL.eq pcr_integer) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> int) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold Num.sub_def [abs_def]) transfer_prover

lemma int_of_integer_of_nat [simp]:
  "int_of_integer (of_nat n) = of_nat n"
  by transfer rule

lift_definition integer_of_nat :: "nat \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma integer_of_nat_eq_of_nat [code]:
  "integer_of_nat = of_nat"
  by transfer rule

lemma int_of_integer_integer_of_nat [simp]:
  "int_of_integer (integer_of_nat n) = of_nat n"
  by transfer rule

lift_definition nat_of_integer :: "integer \<Rightarrow> nat"
  is Int.nat
  .

lemma nat_of_integer_of_nat [simp]:
  "nat_of_integer (of_nat n) = n"
  by transfer simp

lemma int_of_integer_of_int [simp]:
  "int_of_integer (of_int k) = k"
  by transfer simp

lemma nat_of_integer_integer_of_nat [simp]:
  "nat_of_integer (integer_of_nat n) = n"
  by transfer simp

lemma integer_of_int_eq_of_int [simp, code_abbrev]:
  "integer_of_int = of_int"
  by transfer (simp add: fun_eq_iff)

lemma of_int_integer_of [simp]:
  "of_int (int_of_integer k) = (k :: integer)"
  by transfer rule

lemma int_of_integer_numeral [simp]:
  "int_of_integer (numeral k) = numeral k"
  by transfer rule

lemma int_of_integer_sub [simp]:
  "int_of_integer (Num.sub k l) = Num.sub k l"
  by transfer rule

lift_definition integer_of_num :: "num \<Rightarrow> integer"
  is "numeral :: num \<Rightarrow> int"
  .

lemma integer_of_num [code]:
  "integer_of_num num.One = 1"
  "integer_of_num (num.Bit0 n) = (let k = integer_of_num n in k + k)"
  "integer_of_num (num.Bit1 n) = (let k = integer_of_num n in k + k + 1)"
  by (transfer, simp only: numeral.simps Let_def)+

lemma numeral_unfold_integer_of_num:
  "numeral = integer_of_num"
  by (simp add: integer_of_num_def map_fun_def fun_eq_iff)

lemma integer_of_num_triv:
  "integer_of_num Num.One = 1"
  "integer_of_num (Num.Bit0 Num.One) = 2"
  by (transfer, simp)+

instantiation integer :: "{ring_div, equal, linordered_idom}"
begin

lift_definition divide_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "divide :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare divide_integer.rep_eq [simp]

lift_definition modulo_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "modulo :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare modulo_integer.rep_eq [simp]

lift_definition abs_integer :: "integer \<Rightarrow> integer"
  is "abs :: int \<Rightarrow> int"
  .

declare abs_integer.rep_eq [simp]

lift_definition sgn_integer :: "integer \<Rightarrow> integer"
  is "sgn :: int \<Rightarrow> int"
  .

declare sgn_integer.rep_eq [simp]

lift_definition less_eq_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less_eq :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lift_definition less_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lift_definition equal_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "HOL.equal :: int \<Rightarrow> int \<Rightarrow> bool"
  .

instance proof
qed (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] mult_strict_right_mono linear)+

end

lemma [transfer_rule]:
  "rel_fun pcr_integer (rel_fun pcr_integer pcr_integer) (min :: _ \<Rightarrow> _ \<Rightarrow> int) (min :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold min_def [abs_def]) transfer_prover

lemma [transfer_rule]:
  "rel_fun pcr_integer (rel_fun pcr_integer pcr_integer) (max :: _ \<Rightarrow> _ \<Rightarrow> int) (max :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold max_def [abs_def]) transfer_prover

lemma int_of_integer_min [simp]:
  "int_of_integer (min k l) = min (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma int_of_integer_max [simp]:
  "int_of_integer (max k l) = max (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma nat_of_integer_non_positive [simp]:
  "k \<le> 0 \<Longrightarrow> nat_of_integer k = 0"
  by transfer simp

lemma of_nat_of_integer [simp]:
  "of_nat (nat_of_integer k) = max 0 k"
  by transfer auto

instantiation integer :: semiring_numeral_div
begin

definition divmod_integer :: "num \<Rightarrow> num \<Rightarrow> integer \<times> integer"
where
  divmod_integer'_def: "divmod_integer m n = (numeral m div numeral n, numeral m mod numeral n)"

definition divmod_step_integer :: "num \<Rightarrow> integer \<times> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_step_integer l qr = (let (q, r) = qr
    in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
    else (2 * q, r))"

instance proof
  show "divmod m n = (numeral m div numeral n :: integer, numeral m mod numeral n)"
    for m n by (fact divmod_integer'_def)
  show "divmod_step l qr = (let (q, r) = qr
    in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
    else (2 * q, r))" for l and qr :: "integer \<times> integer"
    by (fact divmod_step_integer_def)
qed (transfer,
  fact le_add_diff_inverse2
  semiring_numeral_div_class.div_less
  semiring_numeral_div_class.mod_less
  semiring_numeral_div_class.div_positive
  semiring_numeral_div_class.mod_less_eq_dividend
  semiring_numeral_div_class.pos_mod_bound
  semiring_numeral_div_class.pos_mod_sign
  semiring_numeral_div_class.mod_mult2_eq
  semiring_numeral_div_class.div_mult2_eq
  semiring_numeral_div_class.discrete)+

end

declare divmod_algorithm_code [where ?'a = integer,
  unfolded numeral_unfold_integer_of_num, unfolded integer_of_num_triv,
  code]

lemma integer_of_nat_0: "integer_of_nat 0 = 0"
by transfer simp

lemma integer_of_nat_1: "integer_of_nat 1 = 1"
by transfer simp

lemma integer_of_nat_numeral:
  "integer_of_nat (numeral n) = numeral n"
by transfer simp

subsection \<open>Code theorems for target language integers\<close>

text \<open>Constructors\<close>

definition Pos :: "num \<Rightarrow> integer"
where
  [simp, code_post]: "Pos = numeral"

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer numeral Pos"
  by simp transfer_prover

lemma Pos_fold [code_unfold]:
  "numeral Num.One = Pos Num.One"
  "numeral (Num.Bit0 k) = Pos (Num.Bit0 k)"
  "numeral (Num.Bit1 k) = Pos (Num.Bit1 k)"
  by simp_all

definition Neg :: "num \<Rightarrow> integer"
where
  [simp, code_abbrev]: "Neg n = - Pos n"

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (\<lambda>n. - numeral n) Neg"
  by (simp add: Neg_def [abs_def]) transfer_prover

code_datatype "0::integer" Pos Neg

text \<open>Auxiliary operations\<close>

lift_definition dup :: "integer \<Rightarrow> integer"
  is "\<lambda>k::int. k + k"
  .

lemma dup_code [code]:
  "dup 0 = 0"
  "dup (Pos n) = Pos (Num.Bit0 n)"
  "dup (Neg n) = Neg (Num.Bit0 n)"
  by (transfer, simp only: numeral_Bit0 minus_add_distrib)+

lift_definition sub :: "num \<Rightarrow> num \<Rightarrow> integer"
  is "\<lambda>m n. numeral m - numeral n :: int"
  .

lemma sub_code [code]:
  "sub Num.One Num.One = 0"
  "sub (Num.Bit0 m) Num.One = Pos (Num.BitM m)"
  "sub (Num.Bit1 m) Num.One = Pos (Num.Bit0 m)"
  "sub Num.One (Num.Bit0 n) = Neg (Num.BitM n)"
  "sub Num.One (Num.Bit1 n) = Neg (Num.Bit0 n)"
  "sub (Num.Bit0 m) (Num.Bit0 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit1 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit0 n) = dup (sub m n) + 1"
  "sub (Num.Bit0 m) (Num.Bit1 n) = dup (sub m n) - 1"
  by (transfer, simp add: dbl_def dbl_inc_def dbl_dec_def)+

text \<open>Implementations\<close>

lemma one_integer_code [code, code_unfold]:
  "1 = Pos Num.One"
  by simp

lemma plus_integer_code [code]:
  "k + 0 = (k::integer)"
  "0 + l = (l::integer)"
  "Pos m + Pos n = Pos (m + n)"
  "Pos m + Neg n = sub m n"
  "Neg m + Pos n = sub n m"
  "Neg m + Neg n = Neg (m + n)"
  by (transfer, simp)+

lemma uminus_integer_code [code]:
  "uminus 0 = (0::integer)"
  "uminus (Pos m) = Neg m"
  "uminus (Neg m) = Pos m"
  by simp_all

lemma minus_integer_code [code]:
  "k - 0 = (k::integer)"
  "0 - l = uminus (l::integer)"
  "Pos m - Pos n = sub m n"
  "Pos m - Neg n = Pos (m + n)"
  "Neg m - Pos n = Neg (m + n)"
  "Neg m - Neg n = sub n m"
  by (transfer, simp)+

lemma abs_integer_code [code]:
  "\<bar>k\<bar> = (if (k::integer) < 0 then - k else k)"
  by simp

lemma sgn_integer_code [code]:
  "sgn k = (if k = 0 then 0 else if (k::integer) < 0 then - 1 else 1)"
  by simp

lemma times_integer_code [code]:
  "k * 0 = (0::integer)"
  "0 * l = (0::integer)"
  "Pos m * Pos n = Pos (m * n)"
  "Pos m * Neg n = Neg (m * n)"
  "Neg m * Pos n = Neg (m * n)"
  "Neg m * Neg n = Pos (m * n)"
  by simp_all

definition divmod_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_integer k l = (k div l, k mod l)"

lemma fst_divmod [simp]:
  "fst (divmod_integer k l) = k div l"
  by (simp add: divmod_integer_def)

lemma snd_divmod [simp]:
  "snd (divmod_integer k l) = k mod l"
  by (simp add: divmod_integer_def)

definition divmod_abs :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_abs k l = (\<bar>k\<bar> div \<bar>l\<bar>, \<bar>k\<bar> mod \<bar>l\<bar>)"

lemma fst_divmod_abs [simp]:
  "fst (divmod_abs k l) = \<bar>k\<bar> div \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma snd_divmod_abs [simp]:
  "snd (divmod_abs k l) = \<bar>k\<bar> mod \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma divmod_abs_code [code]:
  "divmod_abs (Pos k) (Pos l) = divmod k l"
  "divmod_abs (Neg k) (Neg l) = divmod k l"
  "divmod_abs (Neg k) (Pos l) = divmod k l"
  "divmod_abs (Pos k) (Neg l) = divmod k l"
  "divmod_abs j 0 = (0, \<bar>j\<bar>)"
  "divmod_abs 0 j = (0, 0)"
  by (simp_all add: prod_eq_iff)

lemma divmod_integer_code [code]:
  "divmod_integer k l =
    (if k = 0 then (0, 0) else if l = 0 then (0, k) else
    (apsnd \<circ> times \<circ> sgn) l (if sgn k = sgn l
      then divmod_abs k l
      else (let (r, s) = divmod_abs k l in
        if s = 0 then (- r, 0) else (- r - 1, \<bar>l\<bar> - s))))"
proof -
  have aux1: "\<And>k l::int. sgn k = sgn l \<longleftrightarrow> k = 0 \<and> l = 0 \<or> 0 < l \<and> 0 < k \<or> l < 0 \<and> k < 0"
    by (auto simp add: sgn_if)
  have aux2: "\<And>q::int. - int_of_integer k = int_of_integer l * q \<longleftrightarrow> int_of_integer k = int_of_integer l * - q" by auto
  show ?thesis
    by (simp add: prod_eq_iff integer_eq_iff case_prod_beta aux1)
      (auto simp add: zdiv_zminus1_eq_if zmod_zminus1_eq_if div_minus_right mod_minus_right aux2)
qed

lemma div_integer_code [code]:
  "k div l = fst (divmod_integer k l)"
  by simp

lemma mod_integer_code [code]:
  "k mod l = snd (divmod_integer k l)"
  by simp

lemma equal_integer_code [code]:
  "HOL.equal 0 (0::integer) \<longleftrightarrow> True"
  "HOL.equal 0 (Pos l) \<longleftrightarrow> False"
  "HOL.equal 0 (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Pos k) 0 \<longleftrightarrow> False"
  "HOL.equal (Pos k) (Pos l) \<longleftrightarrow> HOL.equal k l"
  "HOL.equal (Pos k) (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) 0 \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Pos l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Neg l) \<longleftrightarrow> HOL.equal k l"
  by (simp_all add: equal)

lemma equal_integer_refl [code nbe]:
  "HOL.equal (k::integer) k \<longleftrightarrow> True"
  by (fact equal_refl)

lemma less_eq_integer_code [code]:
  "0 \<le> (0::integer) \<longleftrightarrow> True"
  "0 \<le> Pos l \<longleftrightarrow> True"
  "0 \<le> Neg l \<longleftrightarrow> False"
  "Pos k \<le> 0 \<longleftrightarrow> False"
  "Pos k \<le> Pos l \<longleftrightarrow> k \<le> l"
  "Pos k \<le> Neg l \<longleftrightarrow> False"
  "Neg k \<le> 0 \<longleftrightarrow> True"
  "Neg k \<le> Pos l \<longleftrightarrow> True"
  "Neg k \<le> Neg l \<longleftrightarrow> l \<le> k"
  by simp_all

lemma less_integer_code [code]:
  "0 < (0::integer) \<longleftrightarrow> False"
  "0 < Pos l \<longleftrightarrow> True"
  "0 < Neg l \<longleftrightarrow> False"
  "Pos k < 0 \<longleftrightarrow> False"
  "Pos k < Pos l \<longleftrightarrow> k < l"
  "Pos k < Neg l \<longleftrightarrow> False"
  "Neg k < 0 \<longleftrightarrow> True"
  "Neg k < Pos l \<longleftrightarrow> True"
  "Neg k < Neg l \<longleftrightarrow> l < k"
  by simp_all

lift_definition num_of_integer :: "integer \<Rightarrow> num"
  is "num_of_nat \<circ> nat"
  .

lemma num_of_integer_code [code]:
  "num_of_integer k = (if k \<le> 1 then Num.One
     else let
       (l, j) = divmod_integer k 2;
       l' = num_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + Num.One)"
proof -
  {
    assume "int_of_integer k mod 2 = 1"
    then have "nat (int_of_integer k mod 2) = nat 1" by simp
    moreover assume *: "1 < int_of_integer k"
    ultimately have **: "nat (int_of_integer k) mod 2 = 1" by (simp add: nat_mod_distrib)
    have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (2 * (nat (int_of_integer k) div 2) + nat (int_of_integer k) mod 2)"
      by simp
    then have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + nat (int_of_integer k) mod 2)"
      by (simp add: mult_2)
    with ** have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + 1)"
      by simp
  }
  note aux = this
  show ?thesis
    by (auto simp add: num_of_integer_def nat_of_integer_def Let_def case_prod_beta
      not_le integer_eq_iff less_eq_integer_def
      nat_mult_distrib nat_div_distrib num_of_nat_One num_of_nat_plus_distrib
       mult_2 [where 'a=nat] aux add_One)
qed

lemma nat_of_integer_code [code]:
  "nat_of_integer k = (if k \<le> 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = nat_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + 1)"
proof -
  obtain j where "k = integer_of_int j"
  proof
    show "k = integer_of_int (int_of_integer k)" by simp
  qed
  moreover have "2 * (j div 2) = j - j mod 2"
    by (simp add: minus_mod_eq_mult_div [symmetric] mult.commute)
  ultimately show ?thesis
    by (auto simp add: split_def Let_def modulo_integer_def nat_of_integer_def not_le
      nat_add_distrib [symmetric] Suc_nat_eq_nat_zadd1)
      (auto simp add: mult_2 [symmetric])
qed

lemma int_of_integer_code [code]:
  "int_of_integer k = (if k < 0 then - (int_of_integer (- k))
     else if k = 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = 2 * int_of_integer l
     in if j = 0 then l' else l' + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff minus_mod_eq_mult_div [symmetric])

lemma integer_of_int_code [code]:
  "integer_of_int k = (if k < 0 then - (integer_of_int (- k))
     else if k = 0 then 0
     else let
       l = 2 * integer_of_int (k div 2);
       j = k mod 2
     in if j = 0 then l else l + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff minus_mod_eq_mult_div [symmetric])

hide_const (open) Pos Neg sub dup divmod_abs

subsection \<open>Serializer setup for target language integers\<close>

code_reserved Eval int Integer abs

code_printing
  type_constructor integer \<rightharpoonup>
    (SML) "IntInf.int"
    and (OCaml) "Big'_int.big'_int"
    and (Haskell) "Integer"
    and (Scala) "BigInt"
    and (Eval) "int"
| class_instance integer :: equal \<rightharpoonup>
    (Haskell) -

code_printing
  constant "0::integer" \<rightharpoonup>
    (SML) "!(0/ :/ IntInf.int)"
    and (OCaml) "Big'_int.zero'_big'_int"
    and (Haskell) "!(0/ ::/ Integer)"
    and (Scala) "BigInt(0)"

setup \<open>
  fold (fn target =>
    Numeral.add_code @{const_name Code_Numeral.Pos} I Code_Printer.literal_numeral target
    #> Numeral.add_code @{const_name Code_Numeral.Neg} (op ~) Code_Printer.literal_numeral target)
    ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  constant "plus :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.+ ((_), (_))"
    and (OCaml) "Big'_int.add'_big'_int"
    and (Haskell) infixl 6 "+"
    and (Scala) infixl 7 "+"
    and (Eval) infixl 8 "+"
| constant "uminus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.~"
    and (OCaml) "Big'_int.minus'_big'_int"
    and (Haskell) "negate"
    and (Scala) "!(- _)"
    and (Eval) "~/ _"
| constant "minus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.- ((_), (_))"
    and (OCaml) "Big'_int.sub'_big'_int"
    and (Haskell) infixl 6 "-"
    and (Scala) infixl 7 "-"
    and (Eval) infixl 8 "-"
| constant Code_Numeral.dup \<rightharpoonup>
    (SML) "IntInf.*/ (2,/ (_))"
    and (OCaml) "Big'_int.mult'_big'_int/ (Big'_int.big'_int'_of'_int/ 2)"
    and (Haskell) "!(2 * _)"
    and (Scala) "!(2 * _)"
    and (Eval) "!(2 * _)"
| constant Code_Numeral.sub \<rightharpoonup>
    (SML) "!(raise/ Fail/ \"sub\")"
    and (OCaml) "failwith/ \"sub\""
    and (Haskell) "error/ \"sub\""
    and (Scala) "!sys.error(\"sub\")"
| constant "times :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.* ((_), (_))"
    and (OCaml) "Big'_int.mult'_big'_int"
    and (Haskell) infixl 7 "*"
    and (Scala) infixl 8 "*"
    and (Eval) infixl 9 "*"
| constant Code_Numeral.divmod_abs \<rightharpoonup>
    (SML) "IntInf.divMod/ (IntInf.abs _,/ IntInf.abs _)"
    and (OCaml) "Big'_int.quomod'_big'_int/ (Big'_int.abs'_big'_int _)/ (Big'_int.abs'_big'_int _)"
    and (Haskell) "divMod/ (abs _)/ (abs _)"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k.abs '/% l.abs))"
    and (Eval) "Integer.div'_mod/ (abs _)/ (abs _)"
| constant "HOL.equal :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : IntInf.int) = _)"
    and (OCaml) "Big'_int.eq'_big'_int"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
    and (Eval) infixl 6 "="
| constant "less_eq :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.<= ((_), (_))"
    and (OCaml) "Big'_int.le'_big'_int"
    and (Haskell) infix 4 "<="
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "less :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.< ((_), (_))"
    and (OCaml) "Big'_int.lt'_big'_int"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"
| constant "abs :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.abs"
    and (OCaml) "Big'_int.abs'_big'_int"
    and (Haskell) "Prelude.abs"
    and (Scala) "_.abs"
    and (Eval) "abs"

code_identifier
  code_module Code_Numeral \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

subsection \<open>Type of target language naturals\<close>

typedef natural = "UNIV :: nat set"
  morphisms nat_of_natural natural_of_nat ..

setup_lifting type_definition_natural

lemma natural_eq_iff [termination_simp]:
  "m = n \<longleftrightarrow> nat_of_natural m = nat_of_natural n"
  by transfer rule

lemma natural_eqI:
  "nat_of_natural m = nat_of_natural n \<Longrightarrow> m = n"
  using natural_eq_iff [of m n] by simp

lemma nat_of_natural_of_nat_inverse [simp]:
  "nat_of_natural (natural_of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_natural_inverse [simp]:
  "natural_of_nat (nat_of_natural n) = n"
  by transfer rule

instantiation natural :: "{comm_monoid_diff, semiring_1}"
begin

lift_definition zero_natural :: natural
  is "0 :: nat"
  .

declare zero_natural.rep_eq [simp]

lift_definition one_natural :: natural
  is "1 :: nat"
  .

declare one_natural.rep_eq [simp]

lift_definition plus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "plus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare plus_natural.rep_eq [simp]

lift_definition minus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "minus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare minus_natural.rep_eq [simp]

lift_definition times_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "times :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare times_natural.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

instance natural :: Rings.dvd ..

lemma [transfer_rule]:
  "rel_fun pcr_natural (rel_fun pcr_natural HOL.iff) Rings.dvd Rings.dvd"
  unfolding dvd_def by transfer_prover

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_natural (\<lambda>n::nat. n) (of_nat :: nat \<Rightarrow> natural)"
proof -
  have "rel_fun HOL.eq pcr_natural (of_nat :: nat \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> natural)"
    by (unfold of_nat_def [abs_def]) transfer_prover
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_natural (numeral :: num \<Rightarrow> nat) (numeral :: num \<Rightarrow> natural)"
proof -
  have "rel_fun HOL.eq pcr_natural (numeral :: num \<Rightarrow> nat) (\<lambda>n. of_nat (numeral n))"
    by transfer_prover
  then show ?thesis by simp
qed

lemma nat_of_natural_of_nat [simp]:
  "nat_of_natural (of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_nat [simp, code_abbrev]:
  "natural_of_nat = of_nat"
  by transfer rule

lemma of_nat_of_natural [simp]:
  "of_nat (nat_of_natural n) = n"
  by transfer rule

lemma nat_of_natural_numeral [simp]:
  "nat_of_natural (numeral k) = numeral k"
  by transfer rule

instantiation natural :: "{semiring_div, equal, linordered_semiring}"
begin

lift_definition divide_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "divide :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare divide_natural.rep_eq [simp]

lift_definition modulo_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "modulo :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare modulo_natural.rep_eq [simp]

lift_definition less_eq_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less_eq :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_eq_natural.rep_eq [termination_simp]

lift_definition less_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_natural.rep_eq [termination_simp]

lift_definition equal_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "HOL.equal :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

instance proof
qed (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] linear)+

end

lemma [transfer_rule]:
  "rel_fun pcr_natural (rel_fun pcr_natural pcr_natural) (min :: _ \<Rightarrow> _ \<Rightarrow> nat) (min :: _ \<Rightarrow> _ \<Rightarrow> natural)"
  by (unfold min_def [abs_def]) transfer_prover

lemma [transfer_rule]:
  "rel_fun pcr_natural (rel_fun pcr_natural pcr_natural) (max :: _ \<Rightarrow> _ \<Rightarrow> nat) (max :: _ \<Rightarrow> _ \<Rightarrow> natural)"
  by (unfold max_def [abs_def]) transfer_prover

lemma nat_of_natural_min [simp]:
  "nat_of_natural (min k l) = min (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

lemma nat_of_natural_max [simp]:
  "nat_of_natural (max k l) = max (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

lift_definition natural_of_integer :: "integer \<Rightarrow> natural"
  is "nat :: int \<Rightarrow> nat"
  .

lift_definition integer_of_natural :: "natural \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma natural_of_integer_of_natural [simp]:
  "natural_of_integer (integer_of_natural n) = n"
  by transfer simp

lemma integer_of_natural_of_integer [simp]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by transfer auto

lemma int_of_integer_of_natural [simp]:
  "int_of_integer (integer_of_natural n) = of_nat (nat_of_natural n)"
  by transfer rule

lemma integer_of_natural_of_nat [simp]:
  "integer_of_natural (of_nat n) = of_nat n"
  by transfer rule

lemma [measure_function]:
  "is_measure nat_of_natural"
  by (rule is_measure_trivial)

subsection \<open>Inductive representation of target language naturals\<close>

lift_definition Suc :: "natural \<Rightarrow> natural"
  is Nat.Suc
  .

declare Suc.rep_eq [simp]

old_rep_datatype "0::natural" Suc
  by (transfer, fact nat.induct nat.inject nat.distinct)+

lemma natural_cases [case_names nat, cases type: natural]:
  fixes m :: natural
  assumes "\<And>n. m = of_nat n \<Longrightarrow> P"
  shows P
  using assms by transfer blast

lemma [simp, code]: "size_natural = nat_of_natural"
proof (rule ext)
  fix n
  show "size_natural n = nat_of_natural n"
    by (induct n) simp_all
qed

lemma [simp, code]: "size = nat_of_natural"
proof (rule ext)
  fix n
  show "size n = nat_of_natural n"
    by (induct n) simp_all
qed

lemma natural_decr [termination_simp]:
  "n \<noteq> 0 \<Longrightarrow> nat_of_natural n - Nat.Suc 0 < nat_of_natural n"
  by transfer simp

lemma natural_zero_minus_one: "(0::natural) - 1 = 0"
  by (rule zero_diff)

lemma Suc_natural_minus_one: "Suc n - 1 = n"
  by transfer simp

hide_const (open) Suc

subsection \<open>Code refinement for target language naturals\<close>

lift_definition Nat :: "integer \<Rightarrow> natural"
  is nat
  .

lemma [code_post]:
  "Nat 0 = 0"
  "Nat 1 = 1"
  "Nat (numeral k) = numeral k"
  by (transfer, simp)+

lemma [code abstype]:
  "Nat (integer_of_natural n) = n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by simp

lemma [code_abbrev]:
  "natural_of_integer (Code_Numeral.Pos k) = numeral k"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 0 = 0"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 1 = 1"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (Code_Numeral.Suc n) = integer_of_natural n + 1"
  by transfer simp

lemma [code]:
  "nat_of_natural = nat_of_integer \<circ> integer_of_natural"
  by transfer (simp add: fun_eq_iff)

lemma [code, code_unfold]:
  "case_natural f g n = (if n = 0 then f else g (n - 1))"
  by (cases n rule: natural.exhaust) (simp_all, simp add: Suc_def)

declare natural.rec [code del]

lemma [code abstract]:
  "integer_of_natural (m + n) = integer_of_natural m + integer_of_natural n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m - n) = max 0 (integer_of_natural m - integer_of_natural n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m * n) = integer_of_natural m * integer_of_natural n"
  by transfer (simp add: of_nat_mult)

lemma [code abstract]:
  "integer_of_natural (m div n) = integer_of_natural m div integer_of_natural n"
  by transfer (simp add: zdiv_int)

lemma [code abstract]:
  "integer_of_natural (m mod n) = integer_of_natural m mod integer_of_natural n"
  by transfer (simp add: zmod_int)

lemma [code]:
  "HOL.equal m n \<longleftrightarrow> HOL.equal (integer_of_natural m) (integer_of_natural n)"
  by transfer (simp add: equal)

lemma [code nbe]: "HOL.equal n (n::natural) \<longleftrightarrow> True"
  by (rule equal_class.equal_refl)

lemma [code]: "m \<le> n \<longleftrightarrow> integer_of_natural m \<le> integer_of_natural n"
  by transfer simp

lemma [code]: "m < n \<longleftrightarrow> integer_of_natural m < integer_of_natural n"
  by transfer simp

hide_const (open) Nat

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

code_reflect Code_Numeral
  datatypes natural
  functions "Code_Numeral.Suc" "0 :: natural" "1 :: natural"
    "plus :: natural \<Rightarrow> _" "minus :: natural \<Rightarrow> _"
    "times :: natural \<Rightarrow> _" "divide :: natural \<Rightarrow> _"
    "modulo :: natural \<Rightarrow> _"
    integer_of_natural natural_of_integer

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>
*)
section \<open>\isaheader{Specification of Sets}\<close>
theory SetSpec
imports ICF_Spec_Base
begin
text_raw\<open>\label{thy:SetSpec}\<close>

(*@intf Set
  @abstype 'a set
  Sets
*)

text \<open>
  This theory specifies set operations by means of a mapping to
  HOL's standard sets.
\<close>

(* Drop some notation that gets in the way here*)
(*no_notation member (infixl "mem" 55)*)
notation insert ("set'_ins")

type_synonym ('x,'s) set_\<alpha> = "'s \<Rightarrow> 'x set"
type_synonym ('x,'s) set_invar = "'s \<Rightarrow> bool"
locale set =
  \<comment> \<open>Abstraction to set\<close>
  fixes \<alpha> :: "'s \<Rightarrow> 'x set"
  \<comment> \<open>Invariant\<close>
  fixes invar :: "'s \<Rightarrow> bool"

locale set_no_invar = set +
  assumes invar[simp, intro!]: "\<And>s. invar s"

subsection "Basic Set Functions"

subsubsection "Empty set"

locale set_empty = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = {}"
    "invar (empty ())"

subsubsection "Membership Query"

locale set_memb = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes memb :: "'x \<Rightarrow> 's \<Rightarrow> bool"
  assumes memb_correct:
    "invar s \<Longrightarrow> memb x s \<longleftrightarrow> x \<in> \<alpha> s"

subsubsection "Insertion of Element"

locale set_ins = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes ins :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes ins_correct:
    "invar s \<Longrightarrow> \<alpha> (ins x s) = set_ins x (\<alpha> s)"
    "invar s \<Longrightarrow> invar (ins x s)"

subsubsection "Disjoint Insert"

locale set_ins_dj = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes ins_dj :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes ins_dj_correct:
    "\<lbrakk>invar s; x\<notin>\<alpha> s\<rbrakk> \<Longrightarrow> \<alpha> (ins_dj x s) = set_ins x (\<alpha> s)"
    "\<lbrakk>invar s; x\<notin>\<alpha> s\<rbrakk> \<Longrightarrow> invar (ins_dj x s)"

subsubsection "Deletion of Single Element"

locale set_delete = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes delete :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes delete_correct:
    "invar s \<Longrightarrow> \<alpha> (delete x s) = \<alpha> s - {x}"
    "invar s \<Longrightarrow> invar (delete x s)"

subsubsection "Emptiness Check"

locale set_isEmpty = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = {}"

subsubsection "Bounded Quantifiers"

locale set_ball = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes ball :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> bool"
  assumes ball_correct: "invar S \<Longrightarrow> ball S P \<longleftrightarrow> (\<forall>x\<in>\<alpha> S. P x)"

locale set_bex = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes bex :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> bool"
  assumes bex_correct: "invar S \<Longrightarrow> bex S P \<longleftrightarrow> (\<exists>x\<in>\<alpha> S. P x)"

subsubsection "Finite Set"
locale finite_set = set +
  assumes finite[simp, intro!]: "invar s \<Longrightarrow> finite (\<alpha> s)"

subsubsection "Size"

locale set_size = finite_set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct:
    "invar s \<Longrightarrow> size s = card (\<alpha> s)"

locale set_size_abort = finite_set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes size_abort :: "nat \<Rightarrow> 's \<Rightarrow> nat"
  assumes size_abort_correct:
    "invar s \<Longrightarrow> size_abort m s = min m (card (\<alpha> s))"

subsubsection "Singleton sets"

locale set_sng = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes sng :: "'x \<Rightarrow> 's"
  assumes sng_correct:
    "\<alpha> (sng x) = {x}"
    "invar (sng x)"

locale set_isSng = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes isSng :: "'s \<Rightarrow> bool"
  assumes isSng_correct:
    "invar s \<Longrightarrow> isSng s \<longleftrightarrow> (\<exists>e. \<alpha> s = {e})"
begin
  lemma isSng_correct_exists1 :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (\<exists>!e. (e \<in> \<alpha> s)))"
  by (auto simp add: isSng_correct)

  lemma isSng_correct_card :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (card (\<alpha> s) = 1))"
  by (auto simp add: isSng_correct card_Suc_eq)
end

subsection "Iterators"
text \<open>
  An iterator applies a
  function to a state and all the elements of the set.
  The function is applied in any order. Proofs over the iteration are
  done by establishing invariants over the iteration.
  Iterators may have a break-condition, that interrupts the iteration before
  the last element has been visited.
\<close>

(* Deprecated *)
(*
locale set_iteratei = finite_set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes iteratei :: "'s \<Rightarrow> ('x, '\<sigma>) set_iterator"

  assumes iteratei_rule: "invar S \<Longrightarrow> set_iterator (iteratei S) (\<alpha> S)"
begin
  lemma iteratei_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
   apply (rule set_iterator_rule_P [OF iteratei_rule, of S I \<sigma>0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> \<alpha> S; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
    apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 c f P])
    apply simp_all
  done

  text {* Versions without break condition. *}
  lemma iterate_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I \<sigma>0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 f P])
    apply simp_all
  done
end

lemma set_iteratei_I :
assumes "\<And>s. invar s \<Longrightarrow> set_iterator (iti s) (\<alpha> s)"
shows "set_iteratei \<alpha> invar iti"
proof
  fix s
  assume invar_s: "invar s"
  from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (\<alpha> s)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (\<alpha> s)" .
qed
*)

type_synonym ('x,'s) set_list_it
  = "'s \<Rightarrow> ('x,'x list) set_iterator"
locale poly_set_iteratei_defs =
  fixes list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
begin
  definition iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
    where "iteratei S \<equiv> it_to_it (list_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term iteratei} *}*)

  abbreviation "iterate s \<equiv> iteratei s (\<lambda>_. True)"
end

locale poly_set_iteratei =
  finite_set + poly_set_iteratei_defs list_it
  for list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator" +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  assumes list_it_correct: "invar s \<Longrightarrow> set_iterator (list_it s) (\<alpha> s)"
begin
  lemma iteratei_correct: "invar S \<Longrightarrow> set_iterator (iteratei S) (\<alpha> S)"
    unfolding iteratei_def
    apply (rule it_to_it_correct)
    by (rule list_it_correct)

  lemma pi_iteratei[icf_proper_iteratorI]:
    "proper_it (iteratei S) (iteratei S)"
    unfolding iteratei_def
    by (intro icf_proper_iteratorI)

  lemma iteratei_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
   apply (rule set_iterator_rule_P [OF iteratei_correct, of S I \<sigma>0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> \<alpha> S; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
    apply (rule
      set_iterator_rule_insert_P[OF iteratei_correct, of S I \<sigma>0 c f P])
    apply simp_all
  done

  text \<open>Versions without break condition.\<close>
  lemma iterate_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_correct, of S I \<sigma>0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_correct,
      of S I \<sigma>0 f P])
    apply simp_all
  done

end

subsection "More Set Operations"

subsubsection "Copy"
locale set_copy = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes copy :: "'s1 \<Rightarrow> 's2"
  assumes copy_correct:
    "invar1 s1 \<Longrightarrow> \<alpha>2 (copy s1) = \<alpha>1 s1"
    "invar1 s1 \<Longrightarrow> invar2 (copy s1)"

subsubsection "Union"

locale set_union = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2 + s3: set \<alpha>3 invar3
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  and \<alpha>3 :: "'s3 \<Rightarrow> 'a set" and invar3
  +
  fixes union :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's3"
  assumes union_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> \<alpha>3 (union s1 s2) = \<alpha>1 s1 \<union> \<alpha>2 s2"
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> invar3 (union s1 s2)"

locale set_union_dj =
  s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2 + s3: set \<alpha>3 invar3
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  and \<alpha>3 :: "'s3 \<Rightarrow> 'a set" and invar3
  +
  fixes union_dj :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's3"
  assumes union_dj_correct:
    "\<lbrakk>invar1 s1; invar2 s2; \<alpha>1 s1 \<inter> \<alpha>2 s2 = {}\<rbrakk> \<Longrightarrow> \<alpha>3 (union_dj s1 s2) = \<alpha>1 s1 \<union> \<alpha>2 s2"
    "\<lbrakk>invar1 s1; invar2 s2; \<alpha>1 s1 \<inter> \<alpha>2 s2 = {}\<rbrakk> \<Longrightarrow> invar3 (union_dj s1 s2)"

locale set_union_list = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes union_list :: "'s1 list \<Rightarrow> 's2"
  assumes union_list_correct:
    "\<forall>s1\<in>set l. invar1 s1 \<Longrightarrow> \<alpha>2 (union_list l) = \<Union>{\<alpha>1 s1 |s1. s1 \<in> set l}"
    "\<forall>s1\<in>set l. invar1 s1 \<Longrightarrow> invar2 (union_list l)"

subsubsection "Difference"

locale set_diff = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes diff :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's1"
  assumes diff_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> \<alpha>1 (diff s1 s2) = \<alpha>1 s1 - \<alpha>2 s2"
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> invar1 (diff s1 s2)"

subsubsection "Intersection"

locale set_inter = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2 + s3: set \<alpha>3 invar3
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  and \<alpha>3 :: "'s3 \<Rightarrow> 'a set" and invar3
  +
  fixes inter :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's3"
  assumes inter_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> \<alpha>3 (inter s1 s2) = \<alpha>1 s1 \<inter> \<alpha>2 s2"
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> invar3 (inter s1 s2)"

subsubsection "Subset"

locale set_subset = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes subset :: "'s1 \<Rightarrow> 's2 \<Rightarrow> bool"
  assumes subset_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> subset s1 s2 \<longleftrightarrow> \<alpha>1 s1 \<subseteq> \<alpha>2 s2"

subsubsection "Equal"

locale set_equal = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes equal :: "'s1 \<Rightarrow> 's2 \<Rightarrow> bool"
  assumes equal_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> equal s1 s2 \<longleftrightarrow> \<alpha>1 s1 = \<alpha>2 s2"

subsubsection "Image and Filter"

locale set_image_filter = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'b set" and invar2
  +
  fixes image_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 's1 \<Rightarrow> 's2"
  assumes image_filter_correct_aux:
    "invar1 s \<Longrightarrow> \<alpha>2 (image_filter f s) = { b . \<exists>a\<in>\<alpha>1 s. f a = Some b }"
    "invar1 s \<Longrightarrow> invar2 (image_filter f s)"
begin
  \<comment> \<open>This special form will be checked first by the simplifier:\<close>
  lemma image_filter_correct_aux2:
    "invar1 s \<Longrightarrow>
    \<alpha>2 (image_filter (\<lambda>x. if P x then (Some (f x)) else None) s)
    = f ` {x\<in>\<alpha>1 s. P x}"
    by (auto simp add: image_filter_correct_aux)

  lemmas image_filter_correct =
    image_filter_correct_aux2 image_filter_correct_aux

end

locale set_inj_image_filter = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'b set" and invar2
  +
  fixes inj_image_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 's1 \<Rightarrow> 's2"
  assumes inj_image_filter_correct:
    "\<lbrakk>invar1 s; inj_on f (\<alpha>1 s \<inter> dom f)\<rbrakk> \<Longrightarrow> \<alpha>2 (inj_image_filter f s) = { b . \<exists>a\<in>\<alpha>1 s. f a = Some b }"
    "\<lbrakk>invar1 s; inj_on f (\<alpha>1 s \<inter> dom f)\<rbrakk> \<Longrightarrow> invar2 (inj_image_filter f s)"

subsubsection "Image"

locale set_image = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'b set" and invar2
  +
  fixes image :: "('a \<Rightarrow> 'b) \<Rightarrow> 's1 \<Rightarrow> 's2"
  assumes image_correct:
    "invar1 s \<Longrightarrow> \<alpha>2 (image f s) = f`\<alpha>1 s"
    "invar1 s \<Longrightarrow> invar2 (image f s)"

locale set_inj_image = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'b set" and invar2
  +
  fixes inj_image :: "('a \<Rightarrow> 'b) \<Rightarrow> 's1 \<Rightarrow> 's2"
  assumes inj_image_correct:
    "\<lbrakk>invar1 s; inj_on f (\<alpha>1 s)\<rbrakk> \<Longrightarrow> \<alpha>2 (inj_image f s) = f`\<alpha>1 s"
    "\<lbrakk>invar1 s; inj_on f (\<alpha>1 s)\<rbrakk> \<Longrightarrow> invar2 (inj_image f s)"

subsubsection "Filter"

locale set_filter = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes filter :: "('a \<Rightarrow> bool) \<Rightarrow> 's1 \<Rightarrow> 's2"
  assumes filter_correct:
    "invar1 s \<Longrightarrow> \<alpha>2 (filter P s) = {e. e \<in> \<alpha>1 s \<and> P e}"
    "invar1 s \<Longrightarrow> invar2 (filter P s)"

subsubsection "Union of Set of Sets"

locale set_Union_image =
  s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2 + s3: set \<alpha>3 invar3
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'b set" and invar2
  and \<alpha>3 :: "'s3 \<Rightarrow> 'b set" and invar3
  +
  fixes Union_image :: "('a \<Rightarrow> 's2) \<Rightarrow> 's1 \<Rightarrow> 's3"
  assumes Union_image_correct:
    "\<lbrakk> invar1 s; !!x. x\<in>\<alpha>1 s \<Longrightarrow> invar2 (f x) \<rbrakk> \<Longrightarrow>
      \<alpha>3 (Union_image f s) = \<Union>(\<alpha>2`f`\<alpha>1 s)"
    "\<lbrakk> invar1 s; !!x. x\<in>\<alpha>1 s \<Longrightarrow> invar2 (f x) \<rbrakk> \<Longrightarrow> invar3 (Union_image f s)"

subsubsection "Disjointness Check"

locale set_disjoint = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes disjoint :: "'s1 \<Rightarrow> 's2 \<Rightarrow> bool"
  assumes disjoint_correct:
    "invar1 s1 \<Longrightarrow> invar2 s2 \<Longrightarrow> disjoint s1 s2 \<longleftrightarrow> \<alpha>1 s1 \<inter> \<alpha>2 s2 = {}"

subsubsection "Disjointness Check With Witness"

locale set_disjoint_witness = s1: set \<alpha>1 invar1 + s2: set \<alpha>2 invar2
  for \<alpha>1 :: "'s1 \<Rightarrow> 'a set" and invar1
  and \<alpha>2 :: "'s2 \<Rightarrow> 'a set" and invar2
  +
  fixes disjoint_witness :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 'a option"
  assumes disjoint_witness_correct:
    "\<lbrakk>invar1 s1; invar2 s2\<rbrakk>
      \<Longrightarrow> disjoint_witness s1 s2 = None \<Longrightarrow> \<alpha>1 s1 \<inter> \<alpha>2 s2 = {}"
    "\<lbrakk>invar1 s1; invar2 s2; disjoint_witness s1 s2 = Some a\<rbrakk>
      \<Longrightarrow> a\<in>\<alpha>1 s1 \<inter> \<alpha>2 s2"
begin
  lemma disjoint_witness_None: "\<lbrakk>invar1 s1; invar2 s2\<rbrakk>
    \<Longrightarrow> disjoint_witness s1 s2 = None \<longleftrightarrow> \<alpha>1 s1 \<inter> \<alpha>2 s2 = {}"
    by (case_tac "disjoint_witness s1 s2")
       (auto dest: disjoint_witness_correct)

  lemma disjoint_witnessI: "\<lbrakk>
    invar1 s1;
    invar2 s2;
    \<alpha>1 s1 \<inter> \<alpha>2 s2 \<noteq> {};
    !!a. \<lbrakk>disjoint_witness s1 s2 = Some a\<rbrakk> \<Longrightarrow> P
                            \<rbrakk> \<Longrightarrow> P"
    by (case_tac "disjoint_witness s1 s2")
       (auto dest: disjoint_witness_correct)

end

subsubsection "Selection of Element"

locale set_sel = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes sel :: "'s \<Rightarrow> ('x \<Rightarrow> 'r option) \<Rightarrow> 'r option"
  assumes selE:
    "\<lbrakk> invar s; x\<in>\<alpha> s; f x = Some r;
       !!x r. \<lbrakk>sel s f = Some r; x\<in>\<alpha> s; f x = Some r \<rbrakk> \<Longrightarrow> Q
     \<rbrakk> \<Longrightarrow> Q"
  assumes selI: "\<lbrakk>invar s; \<forall>x\<in>\<alpha> s. f x = None \<rbrakk> \<Longrightarrow> sel s f = None"
begin

  lemma sel_someD:
    "\<lbrakk> invar s; sel s f = Some r; !!x. \<lbrakk>x\<in>\<alpha> s; f x = Some r\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
    apply (cases "\<exists>x\<in>\<alpha> s. \<exists>r. f x = Some r")
    apply (safe)
    apply (erule_tac f=f and x=x in selE)
    apply auto
    apply (drule (1) selI)
    apply simp
    done

  lemma sel_noneD:
    "\<lbrakk> invar s; sel s f = None; x\<in>\<alpha> s \<rbrakk> \<Longrightarrow> f x = None"
    apply (cases "\<exists>x\<in>\<alpha> s. \<exists>r. f x = Some r")
    apply (safe)
    apply (erule_tac f=f and x=xa in selE)
    apply auto
    done
end

\<comment> \<open>Selection of element (without mapping)\<close>
locale set_sel' = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes sel' :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> 'x option"
  assumes sel'E:
    "\<lbrakk> invar s; x\<in>\<alpha> s; P x;
       !!x. \<lbrakk>sel' s P = Some x; x\<in>\<alpha> s; P x \<rbrakk> \<Longrightarrow> Q
     \<rbrakk> \<Longrightarrow> Q"
  assumes sel'I: "\<lbrakk>invar s; \<forall>x\<in>\<alpha> s. \<not> P x \<rbrakk> \<Longrightarrow> sel' s P = None"
begin

  lemma sel'_someD:
    "\<lbrakk> invar s; sel' s P = Some x \<rbrakk> \<Longrightarrow> x\<in>\<alpha> s \<and> P x"
    apply (cases "\<exists>x\<in>\<alpha> s. P x")
    apply (safe)
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    apply (drule (1) sel'I)
    apply simp
    apply (drule (1) sel'I)
    apply simp
    done

  lemma sel'_noneD:
    "\<lbrakk> invar s; sel' s P = None; x\<in>\<alpha> s \<rbrakk> \<Longrightarrow> \<not>P x"
    apply (cases "\<exists>x\<in>\<alpha> s. P x")
    apply (safe)
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    done
end

subsubsection "Conversion of Set to List"

locale set_to_list = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes to_list :: "'s \<Rightarrow> 'x list"
  assumes to_list_correct:
    "invar s \<Longrightarrow> set (to_list s) = \<alpha> s"
    "invar s \<Longrightarrow> distinct (to_list s)"

subsubsection "Conversion of List to Set"

locale list_to_set = set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x set"
  fixes to_set :: "'x list \<Rightarrow> 's"
  assumes to_set_correct:
    "\<alpha> (to_set l) = set l"
    "invar (to_set l)"

subsection "Ordered Sets"

  locale ordered_set = set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar

  locale ordered_finite_set = finite_set \<alpha> invar + ordered_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar

subsubsection "Ordered Iteration"
  (* Deprecated *)
(*  locale set_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes iterateoi_rule:
      "invar s \<Longrightarrow> set_iterator_linord (iterateoi s) (\<alpha> s)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (\<alpha> m) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>\<alpha> m - it. j\<le>k;
        it \<subseteq> \<alpha> m;
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> \<alpha> m;
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>\<alpha> m - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>(\<alpha> m) - it. j\<le>k; it \<subseteq> (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_linord (itoi s) (\<alpha> s)"
  shows "set_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed

  (* Deprecated *)
  locale set_reverse_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> set_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>(\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>(\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m c f \<sigma>0)"
    using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in> (\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule reverse_iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_reverse_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_rev_linord (itoi s) (\<alpha> s)"
  shows "set_reverse_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed
*)

locale poly_set_iterateoi_defs =
  fixes olist_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
begin
  definition iterateoi :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
    where "iterateoi S \<equiv> it_to_it (olist_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term iterateoi} *}*)

  abbreviation "iterateo s \<equiv> iterateoi s (\<lambda>_. True)"
end

locale poly_set_iterateoi =
  finite_set \<alpha> invar + poly_set_iterateoi_defs list_ordered_it
  for \<alpha> :: "'s \<Rightarrow> 'x::linorder set"
  and invar
  and list_ordered_it :: "'s \<Rightarrow> ('x,'x list) set_iterator" +
  assumes list_ordered_it_correct: "invar x
    \<Longrightarrow> set_iterator_linord (list_ordered_it x) (\<alpha> x)"
begin
  lemma iterateoi_correct:
    "invar S \<Longrightarrow> set_iterator_linord (iterateoi S) (\<alpha> S)"
    unfolding iterateoi_def
    apply (rule it_to_it_linord_correct)
    by (rule list_ordered_it_correct)

  lemma pi_iterateoi[icf_proper_iteratorI]:
    "proper_it (iterateoi S) (iterateoi S)"
    unfolding iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar s"
    assumes I0: "I (\<alpha> s) \<sigma>0"
    assumes IP: "!!k it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<forall>j\<in>it. k\<le>j;
      \<forall>j\<in>\<alpha> s - it. j\<le>k;
      it \<subseteq> \<alpha> s;
      I it \<sigma>
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> \<alpha> s;
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<forall>k\<in>it. \<forall>j\<in>\<alpha> s - it. j\<le>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi s c f \<sigma>0)"
  using set_iterator_linord_rule_P [OF iterateoi_correct,
    OF MINV, of I \<sigma>0 c f P, OF I0 _ IF] IP II
  by simp

  lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar s"
    assumes I0: "I ((\<alpha> s)) \<sigma>0"
    assumes IP: "!!k it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>(\<alpha> s) - it. j\<le>k; it \<subseteq> (\<alpha> s); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (iterateo s f \<sigma>0)"
    apply (rule iterateoi_rule_P [where I = I])
    apply (simp_all add: assms)
  done
end

locale poly_set_rev_iterateoi_defs =
  fixes list_rev_it :: "'s \<Rightarrow> ('x::linorder,'x list) set_iterator"
begin
  definition rev_iterateoi :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
    where "rev_iterateoi S \<equiv> it_to_it (list_rev_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term rev_iterateoi} *}*)

  abbreviation "rev_iterateo m \<equiv> rev_iterateoi m (\<lambda>_. True)"
  abbreviation "reverse_iterateoi \<equiv> rev_iterateoi"
  abbreviation "reverse_iterateo \<equiv> rev_iterateo"
end

locale poly_set_rev_iterateoi =
  finite_set \<alpha> invar + poly_set_rev_iterateoi_defs list_rev_it
  for \<alpha> :: "'s \<Rightarrow> 'x::linorder set"
  and invar
  and list_rev_it :: "'s \<Rightarrow> ('x,'x list) set_iterator" +
  assumes list_rev_it_correct:
    "invar s \<Longrightarrow> set_iterator_rev_linord (list_rev_it s) (\<alpha> s)"
begin
  lemma rev_iterateoi_correct:
    "invar S \<Longrightarrow> set_iterator_rev_linord (rev_iterateoi S) (\<alpha> S)"
    unfolding rev_iterateoi_def
    apply (rule it_to_it_rev_linord_correct)
    by (rule list_rev_it_correct)

  lemma pi_rev_iterateoi[icf_proper_iteratorI]:
    "proper_it (rev_iterateoi S) (rev_iterateoi S)"
    unfolding rev_iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar s"
    assumes I0: "I ((\<alpha> s)) \<sigma>0"
    assumes IP: "!!k it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<forall>j\<in>it. k\<ge>j;
      \<forall>j\<in>(\<alpha> s) - it. j\<ge>k;
      it \<subseteq> (\<alpha> s);
      I it \<sigma>
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> (\<alpha> s);
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<forall>k\<in>it. \<forall>j\<in>(\<alpha> s) - it. j\<ge>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (rev_iterateoi s c f \<sigma>0)"
  using set_iterator_rev_linord_rule_P [OF rev_iterateoi_correct,
    OF MINV, of I \<sigma>0 c f P, OF I0 _ IF] IP II
  by simp

  lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar s"
    assumes I0: "I ((\<alpha> s)) \<sigma>0"
    assumes IP: "!!k it \<sigma>. \<lbrakk>
      k \<in> it;
      \<forall>j\<in>it. k\<ge>j;
      \<forall>j\<in> (\<alpha> s) - it. j\<ge>k;
      it \<subseteq> (\<alpha> s);
      I it \<sigma>
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (rev_iterateo s f \<sigma>0)"
    apply (rule rev_iterateoi_rule_P [where I = I])
    apply (simp_all add: assms)
  done

end

subsubsection "Minimal and Maximal Element"

  locale set_min = ordered_set +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder set"
    fixes min :: "'s \<Rightarrow> ('u \<Rightarrow> bool) \<Rightarrow> 'u option"
    assumes min_correct:
      "\<lbrakk> invar s; x\<in>\<alpha> s; P x \<rbrakk> \<Longrightarrow> min s P \<in> Some ` {x\<in>\<alpha> s. P x}"
      "\<lbrakk> invar s; x\<in>\<alpha> s; P x \<rbrakk> \<Longrightarrow> (the (min s P)) \<le> x"
      "\<lbrakk> invar s; {x\<in>\<alpha> s. P x} = {} \<rbrakk> \<Longrightarrow> min s P = None"
  begin
   lemma minE:
     assumes A: "invar s" "x\<in>\<alpha> s" "P x"
     obtains x' where
     "min s P = Some x'" "x'\<in>\<alpha> s" "P x'" "\<forall>x\<in>\<alpha> s. P x \<longrightarrow> x' \<le> x"
   proof -
     from min_correct(1)[of s x P, OF A] have
       MIS: "min s P \<in> Some ` {x \<in> \<alpha> s. P x}" .
     then obtain x' where KV: "min s P = Some x'" "x'\<in>\<alpha> s" "P x'"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule (1) min_correct(2)[OF \<open>invar s\<close>])
       apply (simp add: KV(1))
       done
   qed

   lemmas minI = min_correct(3)

   lemma min_Some:
     "\<lbrakk> invar s; min s P = Some x \<rbrakk> \<Longrightarrow> x\<in>\<alpha> s"
     "\<lbrakk> invar s; min s P = Some x \<rbrakk> \<Longrightarrow> P x"
     "\<lbrakk> invar s; min s P = Some x; x'\<in>\<alpha> s; P x'\<rbrakk> \<Longrightarrow> x\<le>x'"
     apply -
     apply (cases "{x \<in> \<alpha> s. P x} = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[of s _ P])
     apply auto [1]

     apply (cases "{x \<in> \<alpha> s. P x} = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[of s _ P])
     apply auto [1]

     apply (drule (2) min_correct(2)[where P=P])
     apply auto
     done

   lemma min_None:
     "\<lbrakk> invar s; min s P = None \<rbrakk> \<Longrightarrow> {x\<in>\<alpha> s. P x} = {}"
     apply (cases "{x\<in>\<alpha> s. P x} = {}")
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[where P=P])
     apply auto
     done

  end

  locale set_max = ordered_set +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder set"
    fixes max :: "'s \<Rightarrow> ('u \<Rightarrow> bool) \<Rightarrow> 'u option"
    assumes max_correct:
      "\<lbrakk> invar s; x\<in>\<alpha> s; P x \<rbrakk> \<Longrightarrow> max s P \<in> Some ` {x\<in>\<alpha> s. P x}"
      "\<lbrakk> invar s; x\<in>\<alpha> s; P x \<rbrakk> \<Longrightarrow> the (max s P) \<ge> x"
      "\<lbrakk> invar s; {x\<in>\<alpha> s. P x} = {} \<rbrakk> \<Longrightarrow> max s P = None"
  begin
   lemma maxE:
     assumes A: "invar s" "x\<in>\<alpha> s" "P x"
     obtains x' where
     "max s P = Some x'" "x'\<in>\<alpha> s" "P x'" "\<forall>x\<in>\<alpha> s. P x \<longrightarrow> x' \<ge> x"
   proof -
     from max_correct(1)[where P=P, OF A] have
       MIS: "max s P \<in> Some ` {x\<in>\<alpha> s. P x}" .
     then obtain x' where KV: "max s P = Some x'" "x'\<in> \<alpha> s" "P x'"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule (1) max_correct(2)[OF \<open>invar s\<close>])
       apply (simp add: KV(1))
       done
   qed

   lemmas maxI = max_correct(3)

     apply (cases "{x\<in>\<alpha> s. P x} = {}")
     apply (drule (1) max_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) max_correct(1)[of s _ P])
     apply auto [1]

     apply (drule (1) max_correct(2)[where P=P])
     apply auto
     done

   lemma max_None:
     "\<lbrakk> invar s; max s P = None \<rbrakk> \<Longrightarrow> {x\<in>\<alpha> s. P x} = {}"
     apply (cases "{x\<in>\<alpha> s. P x} = {}")
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (1) max_correct(1)[where P=P])
     apply auto
     done

  end

subsection "Conversion to List"
  locale set_to_sorted_list = ordered_set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x::linorder set"
  fixes to_sorted_list :: "'s \<Rightarrow> 'x list"
  assumes to_sorted_list_correct:
    "invar s \<Longrightarrow> set (to_sorted_list s) = \<alpha> s"
    "invar s \<Longrightarrow> distinct (to_sorted_list s)"
    "invar s \<Longrightarrow> sorted (to_sorted_list s)"

  locale set_to_rev_list = ordered_set +
  constrains \<alpha> :: "'s \<Rightarrow> 'x::linorder set"
  fixes to_rev_list :: "'s \<Rightarrow> 'x list"
  assumes to_rev_list_correct:
    "invar s \<Longrightarrow> set (to_rev_list s) = \<alpha> s"
    "invar s \<Longrightarrow> distinct (to_rev_list s)"
    "invar s \<Longrightarrow> sorted (rev (to_rev_list s))"

subsection "Record Based Interface"
  record ('x,'s) set_ops =
    set_op_\<alpha> :: "'s \<Rightarrow> 'x set"
    set_op_invar :: "'s \<Rightarrow> bool"
    set_op_empty :: "unit \<Rightarrow> 's"
    set_op_memb :: "'x \<Rightarrow> 's \<Rightarrow> bool"
    set_op_ins :: "'x \<Rightarrow> 's \<Rightarrow> 's"
    set_op_ins_dj :: "'x \<Rightarrow> 's \<Rightarrow> 's"
    set_op_delete :: "'x \<Rightarrow> 's \<Rightarrow> 's"
    set_op_list_it :: "('x,'s) set_list_it"
    set_op_sng :: "'x \<Rightarrow> 's"
    set_op_isEmpty :: "'s \<Rightarrow> bool"
    set_op_isSng :: "'s \<Rightarrow> bool"
    set_op_ball :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> bool"
    set_op_bex :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> bool"
    set_op_size :: "'s \<Rightarrow> nat"
    set_op_size_abort :: "nat \<Rightarrow> 's \<Rightarrow> nat"
    set_op_union :: "'s \<Rightarrow> 's \<Rightarrow> 's"
    set_op_union_dj :: "'s \<Rightarrow> 's \<Rightarrow> 's"
    set_op_diff :: "'s \<Rightarrow> 's \<Rightarrow> 's"
    set_op_filter :: "('x \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> 's"
    set_op_inter :: "'s \<Rightarrow> 's \<Rightarrow> 's"
    set_op_subset :: "'s \<Rightarrow> 's \<Rightarrow> bool"
    set_op_equal :: "'s \<Rightarrow> 's \<Rightarrow> bool"
    set_op_disjoint :: "'s \<Rightarrow> 's \<Rightarrow> bool"
    set_op_disjoint_witness :: "'s \<Rightarrow> 's \<Rightarrow> 'x option"
    set_op_sel :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> 'x option" \<comment> \<open>Version without mapping\<close>
    set_op_to_list :: "'s \<Rightarrow> 'x list"
    set_op_from_list :: "'x list \<Rightarrow> 's"

  locale StdSetDefs =
    poly_set_iteratei_defs "set_op_list_it ops"
    for ops :: "('x,'s,'more) set_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> == set_op_\<alpha> ops"
    abbreviation invar where "invar == set_op_invar ops"
    abbreviation empty where "empty == set_op_empty ops"
    abbreviation memb where "memb == set_op_memb ops"
    abbreviation ins where "ins == set_op_ins ops"
    abbreviation ins_dj where "ins_dj == set_op_ins_dj ops"
    abbreviation delete where "delete == set_op_delete ops"
    abbreviation list_it where "list_it \<equiv> set_op_list_it ops"
    abbreviation sng where "sng == set_op_sng ops"
    abbreviation isEmpty where "isEmpty == set_op_isEmpty ops"
    abbreviation isSng where "isSng == set_op_isSng ops"
    abbreviation ball where "ball == set_op_ball ops"
    abbreviation bex where "bex == set_op_bex ops"
    abbreviation size where "size == set_op_size ops"
    abbreviation size_abort where "size_abort == set_op_size_abort ops"
    abbreviation union where "union == set_op_union ops"
    abbreviation union_dj where "union_dj == set_op_union_dj ops"
    abbreviation diff where "diff == set_op_diff ops"
    abbreviation filter where "filter == set_op_filter ops"
    abbreviation inter where "inter == set_op_inter ops"
    abbreviation subset where "subset == set_op_subset ops"
    abbreviation equal where "equal == set_op_equal ops"
    abbreviation disjoint where "disjoint == set_op_disjoint ops"
    abbreviation disjoint_witness
      where "disjoint_witness == set_op_disjoint_witness ops"
    abbreviation sel where "sel == set_op_sel ops"
    abbreviation to_list where "to_list == set_op_to_list ops"
    abbreviation from_list where "from_list == set_op_from_list ops"
  end

  locale StdSet = StdSetDefs 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 +
    set_sng \<alpha> invar sng +
    set_isEmpty \<alpha> invar isEmpty +
    set_isSng \<alpha> invar isSng +
    set_ball \<alpha> invar ball +
    set_bex \<alpha> invar bex +
    set_size \<alpha> invar size +
    set_size_abort \<alpha> invar size_abort +
    set_union \<alpha> invar \<alpha> invar \<alpha> invar union +
    set_union_dj \<alpha> invar \<alpha> invar \<alpha> invar union_dj +
    set_diff \<alpha> invar \<alpha> invar diff +
    set_filter \<alpha> invar \<alpha> invar filter +
    set_inter \<alpha> invar \<alpha> invar \<alpha> invar inter +
    set_subset \<alpha> invar \<alpha> invar subset +
    set_equal \<alpha> invar \<alpha> invar equal +
    set_disjoint \<alpha> invar \<alpha> invar disjoint +
    set_disjoint_witness \<alpha> invar \<alpha> invar disjoint_witness +
    set_sel' \<alpha> invar sel +
    set_to_list \<alpha> invar to_list +
    list_to_set \<alpha> invar from_list
    for ops :: "('x,'s,'more) set_ops_scheme"
  begin

    lemmas correct =
      empty_correct
      sng_correct
      memb_correct
      ins_correct
      ins_dj_correct
      delete_correct
      isEmpty_correct
      isSng_correct
      ball_correct
      bex_correct
      size_correct
      size_abort_correct
      union_correct
      union_dj_correct
      diff_correct
      filter_correct
      inter_correct
      subset_correct
      equal_correct
      disjoint_correct
      disjoint_witness_correct
      to_list_correct
      to_set_correct

  end

  lemmas StdSet_intro = StdSet.intro[rem_dup_prems]

  locale StdSet_no_invar = StdSet + set_no_invar \<alpha> invar

  record ('x,'s) oset_ops = "('x::linorder,'s) set_ops" +
    set_op_ordered_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    set_op_rev_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    set_op_min :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> 'x option"
    set_op_max :: "'s \<Rightarrow> ('x \<Rightarrow> bool) \<Rightarrow> 'x option"
    set_op_to_sorted_list :: "'s \<Rightarrow> 'x list"
    set_op_to_rev_list :: "'s \<Rightarrow> 'x list"

  locale StdOSetDefs = StdSetDefs ops
    + poly_set_iterateoi_defs "set_op_ordered_list_it ops"
    + poly_set_rev_iterateoi_defs "set_op_rev_list_it ops"
    for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
  begin
    abbreviation "ordered_list_it \<equiv> set_op_ordered_list_it ops"
    abbreviation "rev_list_it \<equiv> set_op_rev_list_it ops"
    abbreviation min where "min == set_op_min ops"
    abbreviation max where "max == set_op_max ops"
    abbreviation to_sorted_list where
      "to_sorted_list \<equiv> set_op_to_sorted_list ops"
    abbreviation to_rev_list where "to_rev_list \<equiv> set_op_to_rev_list ops"
  end

  locale StdOSet =
    StdOSetDefs ops +
    StdSet ops +
    poly_set_iterateoi \<alpha> invar ordered_list_it +
    poly_set_rev_iterateoi \<alpha> invar rev_list_it +
    set_min \<alpha> invar min +
    set_max \<alpha> invar max +
    set_to_sorted_list \<alpha> invar to_sorted_list +
    set_to_rev_list \<alpha> invar to_rev_list
    for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
  begin
  end

  lemmas StdOSet_intro =
    StdOSet.intro[OF StdSet_intro, rem_dup_prems]

no_notation insert ("set'_ins")
(*notation member (infixl "mem" 55)*)

end


section \<open>Fresh monad operations as class operations\<close>

theory Fresh_Class
imports
  Fresh_Monad
  Name
begin

text \<open>
  The @{const fresh} locale allows arbitrary instantiations. However, this may be inconvenient to
  use. The following class serves as a global instantiation that can be used without interpretation.
  The \<open>arb\<close> parameter of the locale redirects to @{const default}.

  Some instantiations are provided. For @{typ name}s, underscores are appended to generate a fresh
  name.
\<close>

class fresh = linorder + default +
  fixes "next" :: "'a \<Rightarrow> 'a"
  assumes next_ge: "next x > x"

global_interpretation Fresh_Monad.fresh "next" default
  defines fresh_create = create
      and fresh_Next = Next
      and fresh_fNext = fNext
      and fresh_frun = frun_fresh
      and fresh_run = run_fresh
proof
  show "x < next x" for x by (rule next_ge)
qed

lemma [code]: "fresh_run m S = fst (run_state m (fresh_Next S))"
by (simp add: fresh_Next_def fresh_run_def)

instantiation nat :: fresh begin

definition default_nat :: nat where
"default_nat = 0"

definition next_nat where
"next_nat = Suc"

instance
by intro_classes (auto simp: next_nat_def)

end

instantiation char :: default
begin

definition default_char :: char where
"default_char = CHR ''_''"

instance ..

end

instantiation name :: fresh begin

definition default_name where
"default_name = Name ''_''"

definition next_name where
"next_name xs = Name.append xs default"

instance proof
  fix v :: name
  show "v < next v"
    unfolding next_name_def default_name_def
    by (rule name_append_less) simp
qed

end

export_code
  fresh_create fresh_Next fresh_fNext fresh_frun fresh_run
  checking Scala? SML?

end