(*  Title:      HOL/Library/Finite_Map.thy
    Author:     Lars Hupel, TU München
*)

section \<open>Type of finite maps defined as a subtype of maps\<close>

theory Finite_Map
  imports FSet AList
begin

subsection \<open>Auxiliary constants and lemmas over @{type map}\<close>

context includes lifting_syntax begin

abbreviation rel_map :: "('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c) \<Rightarrow> bool" where
"rel_map f \<equiv> op = ===> rel_option f"

lemma map_empty_transfer[transfer_rule]: "rel_map A Map.empty Map.empty"
by transfer_prover

lemma ran_transfer[transfer_rule]: "(rel_map A ===> rel_set A) ran ran"
proof
  fix m n
  assume "rel_map A m n"
  show "rel_set A (ran m) (ran n)"
    proof (rule rel_setI)
      fix x
      assume "x \<in> ran m"
      then obtain a where "m a = Some x"
        unfolding ran_def by auto

      have "rel_option A (m a) (n a)"
        using \<open>rel_map A m n\<close>
        by (auto dest: rel_funD)
      then obtain y where "n a = Some y" "A x y"
        unfolding \<open>m a = _\<close>
        by cases auto
      then show "\<exists>y \<in> ran n. A x y"
        unfolding ran_def by blast
    next
      fix y
      assume "y \<in> ran n"
      then obtain a where "n a = Some y"
        unfolding ran_def by auto

      have "rel_option A (m a) (n a)"
        using \<open>rel_map A m n\<close>
        by (auto dest: rel_funD)
      then obtain x where "m a = Some x" "A x y"
        unfolding \<open>n a = _\<close>
        by cases auto
      then show "\<exists>x \<in> ran m. A x y"
        unfolding ran_def by blast
    qed
qed

lemma ran_alt_def: "ran m = (the \<circ> m) ` dom m"
unfolding ran_def dom_def by force

lemma dom_transfer[transfer_rule]: "(rel_map A ===> op =) dom dom"
proof
  fix m n
  assume "rel_map A m n"
  have "m a \<noteq> None \<longleftrightarrow> n a \<noteq> None" for a
    proof -
      from \<open>rel_map A m n\<close> have "rel_option A (m a) (n a)"
        unfolding rel_fun_def by auto
      then show ?thesis
        by cases auto
    qed
  then show "dom m = dom n"
    by auto
qed

definition map_upd :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_upd k v m = m(k \<mapsto> v)"

lemma map_upd_transfer[transfer_rule]:
  "(op = ===> A ===> rel_map A ===> rel_map A) map_upd map_upd"
unfolding map_upd_def[abs_def]
by transfer_prover

definition map_filter :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_filter P m = (\<lambda>x. if P x then m x else None)"

lemma map_filter_map_of[simp]: "map_filter P (map_of m) = map_of [(k, _) \<leftarrow> m. P k]"
proof
  fix x
  show "map_filter P (map_of m) x = map_of [(k, _) \<leftarrow> m. P k] x"
    by (induct m) (auto simp: map_filter_def)
qed

lemma map_filter_transfer[transfer_rule]:
  "(op = ===> rel_map A ===> rel_map A) map_filter map_filter"
unfolding map_filter_def[abs_def]
by transfer_prover

lemma map_filter_finite[intro]:
  assumes "finite (dom m)"
  shows "finite (dom (map_filter P m))"
proof -
  have "dom (map_filter P m) = Set.filter P (dom m)"
    unfolding map_filter_def Set.filter_def dom_def
    by auto
  then show ?thesis
    using assms
    by (simp add: Set.filter_def)
qed

definition map_drop :: "'a \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_drop a = map_filter (\<lambda>a'. a' \<noteq> a)"

lemma map_drop_transfer[transfer_rule]:
  "(op = ===> rel_map A ===> rel_map A) map_drop map_drop"
unfolding map_drop_def[abs_def]
by transfer_prover

definition map_drop_set :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_drop_set A = map_filter (\<lambda>a. a \<notin> A)"

lemma map_drop_set_transfer[transfer_rule]:
  "(op = ===> rel_map A ===> rel_map A) map_drop_set map_drop_set"
unfolding map_drop_set_def[abs_def]
by transfer_prover

definition map_restrict_set :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_restrict_set A = map_filter (\<lambda>a. a \<in> A)"

lemma map_restrict_set_transfer[transfer_rule]:
  "(op = ===> rel_map A ===> rel_map A) map_restrict_set map_restrict_set"
unfolding map_restrict_set_def[abs_def]
by transfer_prover

lemma map_add_transfer[transfer_rule]:
  "(rel_map A ===> rel_map A ===> rel_map A) op ++ op ++"
unfolding map_add_def[abs_def]
by transfer_prover

definition map_pred :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" where
"map_pred P m \<longleftrightarrow> (\<forall>x. case m x of None \<Rightarrow> True | Some y \<Rightarrow> P x y)"

lemma map_pred_transfer[transfer_rule]:
  "((op = ===> A ===> op =) ===> rel_map A ===> op =) map_pred map_pred"
unfolding map_pred_def[abs_def]
by transfer_prover

definition rel_map_on_set :: "'a set \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c) \<Rightarrow> bool" where
"rel_map_on_set S P = eq_onp (\<lambda>x. x \<in> S) ===> rel_option P"

lemma map_of_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(list_all2 (rel_prod op = A) ===> rel_map A) map_of map_of"
unfolding map_of_def by transfer_prover

end

subsection \<open>Abstract characterisation\<close>

typedef ('a, 'b) fmap = "{m. finite (dom m)} :: ('a \<rightharpoonup> 'b) set"
  morphisms fmlookup Abs_fmap
proof
  show "Map.empty \<in> {m. finite (dom m)}"
    by auto
qed

setup_lifting type_definition_fmap

lemma fmlookup_finite[intro, simp]: "finite (dom (fmlookup m))"
using fmap.fmlookup by auto

lemma fmap_ext:
  assumes "\<And>x. fmlookup m x = fmlookup n x"
  shows "m = n"
using assms
by transfer' auto

subsection \<open>Operations\<close>

context
  includes fset.lifting
begin

lift_definition fmran :: "('a, 'b) fmap \<Rightarrow> 'b fset"
  is ran
  parametric ran_transfer
unfolding ran_alt_def by auto

lemma fmranI: "fmlookup m x = Some y \<Longrightarrow> y |\<in>| fmran m" by transfer' (auto simp: ran_def)

lift_definition fmdom :: "('a, 'b) fmap \<Rightarrow> 'a fset"
  is dom
  parametric dom_transfer
.

lemma fmdom_notI: "fmlookup m x = None \<Longrightarrow> x |\<notin>| fmdom m" by transfer' auto
lemma fmdomI: "fmlookup m x = Some y \<Longrightarrow> x |\<in>| fmdom m" by transfer' auto
lemma fmdom_notD: "x |\<notin>| fmdom m \<Longrightarrow> fmlookup m x = None" by transfer' auto

lift_definition fmdom' :: "('a, 'b) fmap \<Rightarrow> 'a set"
  is dom
  parametric dom_transfer
.

lemma fmdom'_notI: "fmlookup m x = None \<Longrightarrow> x \<notin> fmdom' m" by transfer' auto
lemma fmdom'I: "fmlookup m x = Some y \<Longrightarrow> x \<in> fmdom' m" by transfer' auto
lemma fmdom'_notD: "x \<notin> fmdom' m \<Longrightarrow> fmlookup m x = None" by transfer' auto

lemma fmdom'_alt_def: "fmdom' = fset \<circ> fmdom"
by transfer' force

lemma fmlookup_dom_iff: "x |\<in>| fmdom m \<longleftrightarrow> (\<exists>a. fmlookup m x = Some a)"
by transfer' auto

lift_definition fmempty :: "('a, 'b) fmap"
  is Map.empty
  parametric map_empty_transfer
by simp

lemma fmempty_lookup[simp]: "fmlookup fmempty x = None"
by transfer' simp

lemma fmdom_empty[simp]: "fmdom fmempty = {||}" by transfer' simp
lemma fmdom'_empty[simp]: "fmdom' fmempty = {}" by transfer' simp

lift_definition fmupd :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_upd
  parametric map_upd_transfer
unfolding map_upd_def[abs_def]
by simp

lemma fmupd_lookup[simp]: "fmlookup (fmupd a b m) a' = (if a = a' then Some b else fmlookup m a')"
by transfer' (auto simp: map_upd_def)

lemma fmdom_fmupd[simp]: "fmdom (fmupd a b m) = finsert a (fmdom m)" by transfer (simp add: map_upd_def)
lemma fmdom'_fmupd[simp]: "fmdom' (fmupd a b m) = insert a (fmdom' m)" by transfer (simp add: map_upd_def)

lift_definition fmfilter :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_filter
  parametric map_filter_transfer
by auto

lemma fmdom_filter[simp]: "fmdom (fmfilter P m) = ffilter P (fmdom m)"
by transfer' (auto simp: map_filter_def Set.filter_def split: if_splits)

lemma fmdom'_filter[simp]: "fmdom' (fmfilter P m) = Set.filter P (fmdom' m)"
by transfer' (auto simp: map_filter_def Set.filter_def split: if_splits)

lemma fmlookup_filter[simp]: "fmlookup (fmfilter P m) x = (if P x then fmlookup m x else None)"
by transfer' (auto simp: map_filter_def)

lemma fmfilter_empty[simp]: "fmfilter P fmempty = fmempty"
by transfer' (auto simp: map_filter_def)

lemma fmfilter_true[simp]:
  assumes "\<And>x. x |\<in>| fmdom m \<Longrightarrow> P x"
  shows "fmfilter P m = m"
proof (rule fmap_ext)
  fix x
  have "fmlookup m x = None" if "\<not> P x"
    using that assms
    unfolding fmlookup_dom_iff by fastforce
  then show "fmlookup (fmfilter P m) x = fmlookup m x"
    by simp
qed

lemma fmfilter_false[simp]: "(\<And>x. x |\<in>| fmdom m \<Longrightarrow> \<not> P x) \<Longrightarrow> fmfilter P m = fmempty"
by transfer' (auto simp: map_filter_def fun_eq_iff)

lemma fmfilter_comp[simp]: "fmfilter P (fmfilter Q m) = fmfilter (\<lambda>x. P x \<and> Q x) m"
by transfer' (auto simp: map_filter_def)

lemma fmfilter_comm: "fmfilter P (fmfilter Q m) = fmfilter Q (fmfilter P m)"
unfolding fmfilter_comp by meson

lemma fmfilter_cong[cong]:
  assumes "\<And>x. x |\<in>| fmdom m \<Longrightarrow> P x = Q x"
  shows "fmfilter P m = fmfilter Q m"
proof (rule fmap_ext)
  fix x
  have "fmlookup m x = None" if "P x \<noteq> Q x"
    using that assms
    unfolding fmlookup_dom_iff by fastforce
  then show "fmlookup (fmfilter P m) x = fmlookup (fmfilter Q m) x"
    by auto
qed

lemma fmfilter_cong'[fundef_cong]:
  assumes "\<And>x. x \<in> fmdom' m \<Longrightarrow> P x = Q x"
  shows "fmfilter P m = fmfilter Q m"
proof (rule fmfilter_cong)
  fix x
  assume "x |\<in>| fmdom m"
  then show "P x = Q x"
    using assms
    unfolding fmdom'_alt_def fmember.rep_eq
    by auto
qed

lemma fmfilter_upd[simp]:
  "fmfilter P (fmupd x y m) = (if P x then fmupd x y (fmfilter P m) else fmfilter P m)"
by transfer' (auto simp: map_upd_def map_filter_def)

lift_definition fmdrop :: "'a \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_drop
  parametric map_drop_transfer
unfolding map_drop_def by auto

lemma fmdrop_lookup[simp]: "fmlookup (fmdrop a m) a = None"
by transfer' (auto simp: map_drop_def map_filter_def)

lift_definition fmdrop_set :: "'a set \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_drop_set
  parametric map_drop_set_transfer
unfolding map_drop_set_def by auto

lift_definition fmdrop_fset :: "'a fset \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_drop_set
  parametric map_drop_set_transfer
unfolding map_drop_set_def by auto

lift_definition fmrestrict_set :: "'a set \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_restrict_set
  parametric map_restrict_set_transfer
unfolding map_restrict_set_def by auto

lift_definition fmrestrict_fset :: "'a fset \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is map_restrict_set
  parametric map_restrict_set_transfer
unfolding map_restrict_set_def by auto

lemma fmfilter_alt_defs:
  "fmdrop a = fmfilter (\<lambda>a'. a' \<noteq> a)"
  "fmdrop_set A = fmfilter (\<lambda>a. a \<notin> A)"
  "fmdrop_fset B = fmfilter (\<lambda>a. a |\<notin>| B)"
  "fmrestrict_set A = fmfilter (\<lambda>a. a \<in> A)"
  "fmrestrict_fset B = fmfilter (\<lambda>a. a |\<in>| B)"
by (transfer'; simp add: map_drop_def map_drop_set_def map_restrict_set_def)+

lemma fmdom_drop[simp]: "fmdom (fmdrop a m) = fmdom m - {|a|}" unfolding fmfilter_alt_defs by auto
lemma fmdom'_drop[simp]: "fmdom' (fmdrop a m) = fmdom' m - {a}" unfolding fmfilter_alt_defs by auto
lemma fmdom'_drop_set[simp]: "fmdom' (fmdrop_set A m) = fmdom' m - A" unfolding fmfilter_alt_defs by auto
lemma fmdom_drop_fset[simp]: "fmdom (fmdrop_fset A m) = fmdom m - A" unfolding fmfilter_alt_defs by auto
lemma fmdom'_restrict_set: "fmdom' (fmrestrict_set A m) \<subseteq> A" unfolding fmfilter_alt_defs by auto
lemma fmdom_restrict_fset: "fmdom (fmrestrict_fset A m) |\<subseteq>| A" unfolding fmfilter_alt_defs by auto

lemma fmdom'_drop_fset[simp]: "fmdom' (fmdrop_fset A m) = fmdom' m - fset A"
unfolding fmfilter_alt_defs by transfer' (auto simp: map_filter_def split: if_splits)

lemma fmdom'_restrict_fset: "fmdom' (fmrestrict_fset A m) \<subseteq> fset A"
unfolding fmfilter_alt_defs by transfer' (auto simp: map_filter_def)

lemma fmlookup_drop[simp]:
  "fmlookup (fmdrop a m) x = (if x \<noteq> a then fmlookup m x else None)"
unfolding fmfilter_alt_defs by simp

lemma fmlookup_drop_set[simp]:
  "fmlookup (fmdrop_set A m) x = (if x \<notin> A then fmlookup m x else None)"
unfolding fmfilter_alt_defs by simp

lemma fmlookup_drop_fset[simp]:
  "fmlookup (fmdrop_fset A m) x = (if x |\<notin>| A then fmlookup m x else None)"
unfolding fmfilter_alt_defs by simp

lemma fmlookup_restrict_set[simp]:
  "fmlookup (fmrestrict_set A m) x = (if x \<in> A then fmlookup m x else None)"
unfolding fmfilter_alt_defs by simp

lemma fmlookup_restrict_fset[simp]:
  "fmlookup (fmrestrict_fset A m) x = (if x |\<in>| A then fmlookup m x else None)"
unfolding fmfilter_alt_defs by simp

lemma fmrestrict_set_dom[simp]: "fmrestrict_set (fmdom' m) m = m"
  by (rule fmap_ext) (auto dest: fmdom'_notD)

lemma fmrestrict_fset_dom[simp]: "fmrestrict_fset (fmdom m) m = m"
  by (rule fmap_ext) (auto dest: fmdom_notD)

lemma fmdrop_empty[simp]: "fmdrop a fmempty = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_set_empty[simp]: "fmdrop_set A fmempty = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_fset_empty[simp]: "fmdrop_fset A fmempty = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_set_empty[simp]: "fmrestrict_set A fmempty = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_fset_empty[simp]: "fmrestrict_fset A fmempty = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_set_single[simp]: "fmdrop_set {a} m = fmdrop a m"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_fset_single[simp]: "fmdrop_fset {|a|} m = fmdrop a m"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_set_null[simp]: "fmrestrict_set {} m = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_fset_null[simp]: "fmrestrict_fset {||} m = fmempty"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_comm: "fmdrop a (fmdrop b m) = fmdrop b (fmdrop a m)"
unfolding fmfilter_alt_defs by (rule fmfilter_comm)

lift_definition fmadd :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl "++\<^sub>f" 100)
  is map_add
  parametric map_add_transfer
by simp

lemma fmlookup_add[simp]:
  "fmlookup (m ++\<^sub>f n) x = (if x |\<in>| fmdom n then fmlookup n x else fmlookup m x)"
  by transfer' (auto simp: map_add_def split: option.splits)

lemma fmdom_add[simp]: "fmdom (m ++\<^sub>f n) = fmdom m |\<union>| fmdom n" by transfer' auto
lemma fmdom'_add[simp]: "fmdom' (m ++\<^sub>f n) = fmdom' m \<union> fmdom' n" by transfer' auto

lemma fmadd_drop_left_dom: "fmdrop_fset (fmdom n) m ++\<^sub>f n = m ++\<^sub>f n"
  by (rule fmap_ext) auto

lemma fmadd_restrict_right_dom: "fmrestrict_fset (fmdom n) (m ++\<^sub>f n) = n"
  by (rule fmap_ext) (auto dest: fmdom_notD)

lemma fmfilter_add_distrib[simp]: "fmfilter P (m ++\<^sub>f n) = fmfilter P m ++\<^sub>f fmfilter P n"
by transfer' (auto simp: map_filter_def map_add_def)

lemma fmdrop_add_distrib[simp]: "fmdrop a (m ++\<^sub>f n) = fmdrop a m ++\<^sub>f fmdrop a n"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_set_add_distrib[simp]: "fmdrop_set A (m ++\<^sub>f n) = fmdrop_set A m ++\<^sub>f fmdrop_set A n"
  unfolding fmfilter_alt_defs by simp

lemma fmdrop_fset_add_distrib[simp]: "fmdrop_fset A (m ++\<^sub>f n) = fmdrop_fset A m ++\<^sub>f fmdrop_fset A n"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_set_add_distrib[simp]:
  "fmrestrict_set A (m ++\<^sub>f n) = fmrestrict_set A m ++\<^sub>f fmrestrict_set A n"
  unfolding fmfilter_alt_defs by simp

lemma fmrestrict_fset_add_distrib[simp]:
  "fmrestrict_fset A (m ++\<^sub>f n) = fmrestrict_fset A m ++\<^sub>f fmrestrict_fset A n"
  unfolding fmfilter_alt_defs by simp

lemma fmadd_empty[simp]: "fmempty ++\<^sub>f m = m" "m ++\<^sub>f fmempty = m"
by (transfer'; auto)+

lemma fmadd_idempotent[simp]: "m ++\<^sub>f m = m"
by transfer' (auto simp: map_add_def split: option.splits)

lemma fmadd_assoc[simp]: "m ++\<^sub>f (n ++\<^sub>f p) = m ++\<^sub>f n ++\<^sub>f p"
by transfer' simp

lift_definition fmpred :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) fmap \<Rightarrow> bool"
  is map_pred
  parametric map_pred_transfer
.

lemma fmpredI[intro]:
  assumes "\<And>x y. fmlookup m x = Some y \<Longrightarrow> P x y"
  shows "fmpred P m"
using assms
by transfer' (auto simp: map_pred_def split: option.splits)

lemma fmpredD[dest]: "fmpred P m \<Longrightarrow> fmlookup m x = Some y \<Longrightarrow> P x y"
by transfer' (auto simp: map_pred_def split: option.split_asm)

lemma fmpred_iff: "fmpred P m \<longleftrightarrow> (\<forall>x y. fmlookup m x = Some y \<longrightarrow> P x y)"
by auto

lemma fmpred_alt_def: "fmpred P m \<longleftrightarrow> fBall (fmdom m) (\<lambda>x. P x (the (fmlookup m x)))"
unfolding fmpred_iff
apply auto
apply (subst (asm) fmlookup_dom_iff)
apply simp
apply (rename_tac x y)
apply (erule_tac x = x in fBallE)
apply simp
by (simp add: fmlookup_dom_iff)

lemma fmpred_empty[intro!, simp]: "fmpred P fmempty"
by auto

lemma fmpred_upd[intro]: "fmpred P m \<Longrightarrow> P x y \<Longrightarrow> fmpred P (fmupd x y m)"
by transfer' (auto simp: map_pred_def map_upd_def)

lemma fmpred_updD[dest]: "fmpred P (fmupd x y m) \<Longrightarrow> P x y"
by auto

lemma fmpred_add[intro]: "fmpred P m \<Longrightarrow> fmpred P n \<Longrightarrow> fmpred P (m ++\<^sub>f n)"
by transfer' (auto simp: map_pred_def map_add_def split: option.splits)

lemma fmpred_filter[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmfilter Q m)"
by transfer' (auto simp: map_pred_def map_filter_def)

lemma fmpred_drop[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmdrop a m)"
  by (auto simp: fmfilter_alt_defs)

lemma fmpred_drop_set[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmdrop_set A m)"
  by (auto simp: fmfilter_alt_defs)

lemma fmpred_drop_fset[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmdrop_fset A m)"
  by (auto simp: fmfilter_alt_defs)

lemma fmpred_restrict_set[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmrestrict_set A m)"
  by (auto simp: fmfilter_alt_defs)

lemma fmpred_restrict_fset[intro]: "fmpred P m \<Longrightarrow> fmpred P (fmrestrict_fset A m)"
  by (auto simp: fmfilter_alt_defs)

lemma fmpred_cases[consumes 1]:
  assumes "fmpred P m"
  obtains (none) "fmlookup m x = None" | (some) y where "fmlookup m x = Some y" "P x y"
using assms by auto

lift_definition fmsubset :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> bool" (infix "\<subseteq>\<^sub>f" 50)
  is map_le
.

lemma fmsubset_alt_def: "m \<subseteq>\<^sub>f n \<longleftrightarrow> fmpred (\<lambda>k v. fmlookup n k = Some v) m"
by transfer' (auto simp: map_pred_def map_le_def dom_def split: option.splits)

lemma fmsubset_pred: "fmpred P m \<Longrightarrow> n \<subseteq>\<^sub>f m \<Longrightarrow> fmpred P n"
unfolding fmsubset_alt_def fmpred_iff
by auto

lemma fmsubset_filter_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmfilter P m \<subseteq>\<^sub>f fmfilter P n"
unfolding fmsubset_alt_def fmpred_iff
by auto

lemma fmsubset_drop_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmdrop a m \<subseteq>\<^sub>f fmdrop a n"
unfolding fmfilter_alt_defs by (rule fmsubset_filter_mono)

lemma fmsubset_drop_set_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmdrop_set A m \<subseteq>\<^sub>f fmdrop_set A n"
unfolding fmfilter_alt_defs by (rule fmsubset_filter_mono)

lemma fmsubset_drop_fset_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmdrop_fset A m \<subseteq>\<^sub>f fmdrop_fset A n"
unfolding fmfilter_alt_defs by (rule fmsubset_filter_mono)

lemma fmsubset_restrict_set_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmrestrict_set A m \<subseteq>\<^sub>f fmrestrict_set A n"
unfolding fmfilter_alt_defs by (rule fmsubset_filter_mono)

lemma fmsubset_restrict_fset_mono: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmrestrict_fset A m \<subseteq>\<^sub>f fmrestrict_fset A n"
unfolding fmfilter_alt_defs by (rule fmsubset_filter_mono)

lift_definition fmap_of_list :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) fmap"
  is map_of
  parametric map_of_transfer
by (rule finite_dom_map_of)

lemma fmap_of_list_simps[simp]:
  "fmap_of_list [] = fmempty"
  "fmap_of_list ((k, v) # kvs) = fmupd k v (fmap_of_list kvs)"
by (transfer, simp add: map_upd_def)+

lemma fmap_of_list_app[simp]: "fmap_of_list (xs @ ys) = fmap_of_list ys ++\<^sub>f fmap_of_list xs"
by transfer' simp

lemma fmupd_alt_def: "fmupd k v m = m ++\<^sub>f fmap_of_list [(k, v)]"
by transfer' (auto simp: map_upd_def)

lemma fmpred_of_list[intro]:
  assumes "\<And>k v. (k, v) \<in> set xs \<Longrightarrow> P k v"
  shows "fmpred P (fmap_of_list xs)"
using assms
by (induction xs) (transfer'; auto simp: map_pred_def)+

lemma fmap_of_list_SomeD: "fmlookup (fmap_of_list xs) k = Some v \<Longrightarrow> (k, v) \<in> set xs"
by transfer' (auto dest: map_of_SomeD)

lift_definition fmrel_on_set :: "'a set \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'c) fmap \<Rightarrow> bool"
  is rel_map_on_set
.

lift_definition fmrel_on_fset :: "'a fset \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'c) fmap \<Rightarrow> bool"
  is rel_map_on_set
.

lemma fmrel_on_fset_alt_def: "fmrel_on_fset S P m n \<longleftrightarrow> fBall S (\<lambda>x. rel_option P (fmlookup m x) (fmlookup n x))"
by transfer' (auto simp: rel_map_on_set_def eq_onp_def rel_fun_def)

lemma fmrel_on_fsetI[intro]:
  assumes "\<And>x. x |\<in>| S \<Longrightarrow> rel_option P (fmlookup m x) (fmlookup n x)"
  shows "fmrel_on_fset S P m n"
using assms
unfolding fmrel_on_fset_alt_def by auto

lemma fmrel_on_fset_mono[mono]: "R \<le> Q \<Longrightarrow> fmrel_on_fset S R \<le> fmrel_on_fset S Q"
unfolding fmrel_on_fset_alt_def[abs_def]
apply (intro le_funI fBall_mono)
using option.rel_mono by auto

lemma fmrel_on_fsetD: "x |\<in>| S \<Longrightarrow> fmrel_on_fset S P m n \<Longrightarrow> rel_option P (fmlookup m x) (fmlookup n x)"
unfolding fmrel_on_fset_alt_def
by auto

lemma fmrel_on_fsubset: "fmrel_on_fset S R m n \<Longrightarrow> T |\<subseteq>| S \<Longrightarrow> fmrel_on_fset T R m n"
unfolding fmrel_on_fset_alt_def
by auto

end

subsection \<open>BNF setup\<close>

lift_bnf ('a, fmran': 'b) fmap [wits: Map.empty]
  for map: fmmap
      rel: fmrel
  by auto

text \<open>
  Unfortunately, @{command lift_bnf} doesn't register the definitional theorems. We're doing it
  manually below.
\<close>

local_setup \<open>fn lthy =>
  let
    val SOME bnf = BNF_Def.bnf_of lthy @{type_name fmap}
  in
    lthy
    |> Local_Theory.note ((@{binding fmmap_def}, []), [BNF_Def.map_def_of_bnf bnf]) |> #2
    |> Local_Theory.note ((@{binding fmran'_def}, []), BNF_Def.set_defs_of_bnf bnf) |> #2
    |> Local_Theory.note ((@{binding fmrel_def}, []), [BNF_Def.rel_def_of_bnf bnf]) |> #2
  end
\<close>

context includes lifting_syntax begin

lemma fmmap_transfer[transfer_rule]:
  "(op = ===> pcr_fmap op = op = ===> pcr_fmap op = op =) (\<lambda>f. op \<circ> (map_option f)) fmmap"
  unfolding fmmap_def
  by (rule rel_funI ext)+ (auto simp: fmap.Abs_fmap_inverse fmap.pcr_cr_eq cr_fmap_def)

lemma fmran'_transfer[transfer_rule]:
  "(pcr_fmap op = op = ===> op =) (\<lambda>x. UNION (range x) set_option) fmran'"
  unfolding fmran'_def fmap.pcr_cr_eq cr_fmap_def by fastforce

lemma fmrel_transfer[transfer_rule]:
  "(op = ===> pcr_fmap op = op = ===> pcr_fmap op = op = ===> op =) rel_map fmrel"
  unfolding fmrel_def fmap.pcr_cr_eq cr_fmap_def vimage2p_def by fastforce

end

lemma fmran'_alt_def: "fmran' = fset \<circ> fmran"
including fset.lifting
by transfer' (auto simp: ran_def fun_eq_iff)

lemma fmran'I: "fmlookup m x = Some y \<Longrightarrow> y \<in> fmran' m"
by transfer' auto

lemma fmrel_iff: "fmrel R m n \<longleftrightarrow> (\<forall>x. rel_option R (fmlookup m x) (fmlookup n x))"
by transfer' (auto simp: rel_fun_def)

lemma fmrelI[intro]:
  assumes "\<And>x. rel_option R (fmlookup m x) (fmlookup n x)"
  shows "fmrel R m n"
using assms
by transfer' auto

lemma fmempty_transfer[simp, intro, transfer_rule]: "fmrel P fmempty fmempty"
by transfer auto

lemma fmrel_upd[intro]: "fmrel P m n \<Longrightarrow> P x y \<Longrightarrow> fmrel P (fmupd k x m) (fmupd k y n)"
by transfer' (auto simp: map_upd_def rel_fun_def)

lemma fmrelD[dest]: "fmrel P m n \<Longrightarrow> rel_option P (fmlookup m x) (fmlookup n x)"
by transfer' (auto simp: rel_fun_def)

lemma fmrel_addI[intro]:
  assumes "fmrel P m n" "fmrel P a b"
  shows "fmrel P (m ++\<^sub>f a) (n ++\<^sub>f b)"
using assms
apply transfer'
apply (auto simp: rel_fun_def map_add_def)
by (metis option.case_eq_if option.collapse option.rel_sel)

lemma fmrel_cases[consumes 1]:
  assumes "fmrel P m n"
  obtains (none) "fmlookup m x = None" "fmlookup n x = None"
        | (some) a b where "fmlookup m x = Some a" "fmlookup n x = Some b" "P a b"
proof -
  from assms have "rel_option P (fmlookup m x) (fmlookup n x)"
    by auto
  then show thesis
    using none some
    by (cases rule: option.rel_cases) auto
qed

lemma fmrel_filter[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmfilter Q m) (fmfilter Q n)"
unfolding fmrel_iff by auto

lemma fmrel_drop[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmdrop a m) (fmdrop a n)"
  unfolding fmfilter_alt_defs by blast

lemma fmrel_drop_set[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmdrop_set A m) (fmdrop_set A n)"
  unfolding fmfilter_alt_defs by blast

lemma fmrel_drop_fset[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmdrop_fset A m) (fmdrop_fset A n)"
  unfolding fmfilter_alt_defs by blast

lemma fmrel_restrict_set[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmrestrict_set A m) (fmrestrict_set A n)"
  unfolding fmfilter_alt_defs by blast

lemma fmrel_restrict_fset[intro]: "fmrel P m n \<Longrightarrow> fmrel P (fmrestrict_fset A m) (fmrestrict_fset A n)"
  unfolding fmfilter_alt_defs by blast

lemma pred_fmap_fmpred[simp]: "pred_fmap P = fmpred (\<lambda>_. P)"
unfolding fmap.pred_set fmran'_alt_def
including fset.lifting
apply transfer'
apply (rule ext)
apply (auto simp: map_pred_def ran_def split: option.splits dest: )
done

lemma pred_fmap_id[simp]: "pred_fmap id (fmmap f m) \<longleftrightarrow> pred_fmap f m"
unfolding fmap.pred_set fmap.set_map
by simp

lemma fmlookup_map[simp]: "fmlookup (fmmap f m) x = map_option f (fmlookup m x)"
by transfer' auto

lemma fmpred_map[simp]: "fmpred P (fmmap f m) \<longleftrightarrow> fmpred (\<lambda>k v. P k (f v)) m"
unfolding fmpred_iff pred_fmap_def fmap.set_map
by auto

lemma fmpred_id[simp]: "fmpred (\<lambda>_. id) (fmmap f m) \<longleftrightarrow> fmpred (\<lambda>_. f) m"
by simp

lemma fmmap_add[simp]: "fmmap f (m ++\<^sub>f n) = fmmap f m ++\<^sub>f fmmap f n"
by transfer' (auto simp: map_add_def fun_eq_iff split: option.splits)

lemma fmmap_empty[simp]: "fmmap f fmempty = fmempty"
by transfer auto

lemma fmdom_map[simp]: "fmdom (fmmap f m) = fmdom m"
including fset.lifting
by transfer' simp

lemma fmdom'_map[simp]: "fmdom' (fmmap f m) = fmdom' m"
by transfer' simp

lemma fmfilter_fmmap[simp]: "fmfilter P (fmmap f m) = fmmap f (fmfilter P m)"
by transfer' (auto simp: map_filter_def)

lemma fmdrop_fmmap[simp]: "fmdrop a (fmmap f m) = fmmap f (fmdrop a m)" unfolding fmfilter_alt_defs by simp
lemma fmdrop_set_fmmap[simp]: "fmdrop_set A (fmmap f m) = fmmap f (fmdrop_set A m)" unfolding fmfilter_alt_defs by simp
lemma fmdrop_fset_fmmap[simp]: "fmdrop_fset A (fmmap f m) = fmmap f (fmdrop_fset A m)" unfolding fmfilter_alt_defs by simp
lemma fmrestrict_set_fmmap[simp]: "fmrestrict_set A (fmmap f m) = fmmap f (fmrestrict_set A m)" unfolding fmfilter_alt_defs by simp
lemma fmrestrict_fset_fmmap[simp]: "fmrestrict_fset A (fmmap f m) = fmmap f (fmrestrict_fset A m)" unfolding fmfilter_alt_defs by simp

lemma fmmap_subset[intro]: "m \<subseteq>\<^sub>f n \<Longrightarrow> fmmap f m \<subseteq>\<^sub>f fmmap f n"
by transfer' (auto simp: map_le_def)

subsection \<open>Code setup\<close>

instantiation fmap :: (type, equal) equal begin

definition "equal_fmap \<equiv> fmrel HOL.equal"

instance proof
  fix m n :: "('a, 'b) fmap"
  have "fmrel op = m n \<longleftrightarrow> (m = n)"
    by transfer' (simp add: option.rel_eq rel_fun_eq)
  then show "equal_class.equal m n \<longleftrightarrow> (m = n)"
    unfolding equal_fmap_def
    by (simp add: equal_eq[abs_def])
qed

end

lemma fBall_alt_def: "fBall S P \<longleftrightarrow> (\<forall>x. x |\<in>| S \<longrightarrow> P x)"
by force

lemma fmrel_code:
  "fmrel R m n \<longleftrightarrow>
    fBall (fmdom m) (\<lambda>x. rel_option R (fmlookup m x) (fmlookup n x)) \<and>
    fBall (fmdom n) (\<lambda>x. rel_option R (fmlookup m x) (fmlookup n x))"
unfolding fmrel_iff fmlookup_dom_iff fBall_alt_def
by (metis option.collapse option.rel_sel)

lemmas fmap_generic_code =
  fmrel_code
  fmran'_alt_def
  fmdom'_alt_def
  fmfilter_alt_defs
  pred_fmap_fmpred
  fmsubset_alt_def
  fmupd_alt_def
  fmrel_on_fset_alt_def
  fmpred_alt_def

code_datatype fmap_of_list
quickcheck_generator fmap constructors: fmap_of_list

context includes fset.lifting begin

lemma [code]: "fmempty = fmap_of_list []"
by transfer simp

lemma [code]: "fmran (fmap_of_list m) = snd |`| fset_of_list (AList.clearjunk m)"
by transfer (auto simp: ran_map_of)

lemma [code]: "fmdom (fmap_of_list m) = fst |`| fset_of_list m"
by transfer (auto simp: dom_map_of_conv_image_fst)

lemma [code]: "fmfilter P (fmap_of_list m) = fmap_of_list (filter (\<lambda>(k, _). P k) m)"
by transfer' auto

lemma [code]: "fmap_of_list m ++\<^sub>f fmap_of_list n = fmap_of_list (AList.merge m n)"
by transfer (simp add: merge_conv')

lemma [code]: "fmmap f (fmap_of_list m) = fmap_of_list (map (apsnd f) m)"
apply transfer
apply (subst map_of_map[symmetric])
apply (auto simp: apsnd_def map_prod_def)
done

end

declare fmap_generic_code[code]

lifting_update fmap.lifting
lifting_forget fmap.lifting

end


theory Syntax
imports
  Complex_Main
  Word_Lib.Word_Lib
  Word_Lib.Word_Lemmas
  Notation_Word
  Notation_HOL
  Finite_String
abbrevs Zero = "\<^bold>0"
  and One = "\<^bold>1"
  and Geq = "\<^bold>\<ge>"
  and Leq = "\<^bold>\<le>"
  and Ge = "\<^bold>>"
  and Le = "\<^bold><"
  and Equals = "\<^bold>="
begin
section \<open>Syntax\<close>
text \<open>
  We define the syntax of dL terms, formulas and hybrid programs. As in
  CADE'15, the syntax allows arbitrarily nested differentials. However,
  the semantics of such terms is very surprising (e.g. (x')' is zero in
  every state), so we define predicates dfree and dsafe to describe terms
  with no differentials and no nested differentials, respectively.

  In keeping with the CADE'15 presentation we currently make the simplifying
  assumption that all terms are smooth, and thus division and arbitrary
  exponentiation are absent from the syntax. Several other standard logical
  constructs are implemented as derived forms to reduce the soundness burden.

  The types of formulas and programs are parameterized by three finite types
  ('a, 'b, 'c) used as identifiers for function constants, context constants, and
  everything else, respectively. These type variables are distinct because some
  substitution operations affect one type variable while leaving the others unchanged.
  Because these types will be finite in practice, it is more useful to think of them
  as natural numbers that happen to be represented as types (due to HOL's lack of dependent types).
  The types of terms and ODE systems follow the same approach, but have only two type
  variables because they cannot contain contexts.
\<close>
type_synonym word = "32 Word.word"

definition NEG_INF::"word"
where "NEG_INF = -((2 ^ 31) -1)"

definition POS_INF::"word"
where "POS_INF = (2^31) - 1"

typedef bword = "{n::word. sint n \<ge> sint NEG_INF \<and> sint n \<le> sint POS_INF}"
  apply(rule exI[where x=NEG_INF])
  by (auto simp add: NEG_INF_def POS_INF_def)

(* Numeric literals *)
type_synonym lit = bword

setup_lifting type_definition_bword

lift_definition bword_zero::"bword" is "0::32 Word.word"
  by(auto simp add: POS_INF_def NEG_INF_def)

lift_definition bword_one::"bword" is "1::32 Word.word"
  by(auto simp add: POS_INF_def NEG_INF_def)

lift_definition bword_neg_one::"bword" is "-1::32 Word.word"
    by(auto simp add: POS_INF_def NEG_INF_def)

datatype trm =
(* Real-valued variables given meaning by the state and modified by programs. *)
  Var ident
| Const lit
(* A function (applied to its arguments) consists of an identifier for the function
 * and a function 'c \<Rightarrow> trm (where 'c is a finite type) which specifies one
 * argument of the function for each element of type 'c. To simulate a function with
 * less than 'c arguments, set the remaining arguments to a constant, such as Const 0*)
| Function ident "ident \<Rightarrow> trm" ("$f")
(* A functional is analogous to a function, but can depend on ALL state variables*)
| Functional ident ("$$F")
(* A functional that can depend only on base variables and thus is differentiable*)
(*| DFunctional 'a ("$$F'")*)
| Plus trm trm
| Times trm trm
| Div trm trm
| Neg trm
| Max trm trm
| Min trm trm
| Abs trm
(* A (real-valued) variable standing for a differential, such as x', given meaning by the state
 * and modified by programs. *)
| DiffVar ident ("$''")
(* The differential of an arbitrary term (\<theta>)' *)
| Differential trm

definition Zero::trm ("\<^bold>0")
  where "Zero = Const (bword_zero)"

definition One::trm ("\<^bold>1")
  where "One = Const (bword_one)"

type_synonym space  = "ident option"

definition All ::"space" where Space_All_def[simp]:"All = None"
definition NB ::"ident \<Rightarrow> space" where Space_NB_def[simp]:"NB = Some"
(*
datatype 'c space =
  All
| NB 'c (* one variable not-bound *)*)

datatype ODE =
(* Variable standing for an ODE system, given meaning by the interpretation *)
  OVar ident  space
(* Singleton ODE defining x' = \<theta>, where \<theta> may or may not contain x
 * (but must not contain differentials) *)
| OSing ident trm
(* The product OProd ODE1 ODE2 composes two ODE systems in parallel, e.g.
 * OProd (x' = y) (y' = -x) is the system {x' = y, y' = -x} *)
| OProd ODE ODE

fun oprod::"ODE \<Rightarrow> ODE \<Rightarrow> ODE"
  where "oprod (OSing x t) ODE2 = (OProd (OSing x t) ODE2)"
  | "oprod (OVar c d) ODE2 = (OProd (OVar c d) ODE2)"
  | "oprod (OProd ll lr) ODE2 = oprod ll (oprod lr  ODE2)"

lemma oprod_induct:
  fixes l r::"ODE" and P::"ODE \<Rightarrow> ODE \<Rightarrow> bool"
  assumes BC1:"(\<And>x t ODE2. P (OSing x t) ODE2)"
  assumes BC2:"(\<And>c d ODE2. (P (OVar c d) ODE2))"
  assumes  IH:"\<And>l1 l2 x. (\<And>x. P l1 x) \<Longrightarrow> (\<And>x. P l2 x) \<Longrightarrow> P (OProd l1 l2) x"
  shows "P l r"
  apply(induction l arbitrary:r)
    apply(rule BC2)
   apply(rule BC1)
  by(rule IH)

datatype hp =
(* Variables standing for programs, given meaning by the interpretation. *)
  Pvar ident                           ("$\<alpha>")
(* Assignment to a real-valued variable x := \<theta> *)
| Assign ident "trm"                (infixr ":=" 10)
(* Nondeterministic assignment to a real-valued variable x := * *)
| AssignAny ident
(* Assignment to a differential variable*)
| DiffAssign ident "trm"
(* Program ?\<phi> succeeds iff \<phi> holds in current state. *)
| Test "formula"                 ("?")
(* An ODE program is an ODE system with some evolution domain. *)
| EvolveODE "ODE" "formula"
(* Non-deterministic choice between two programs a and b *)
| Choice "hp" "hp"            (infixl "\<union>\<union>" 10)
(* Sequential composition of two programs a and b *)
| Sequence "hp"  "hp"         (infixr ";;" 8)
(* Nondeterministic repetition of a program "a", zero or more times. *)
| Loop "hp"                      ("_**")
and formula =
  Geq "trm" "trm"                (infix "\<^bold>\<ge>" 50)
| Prop ident "ident \<Rightarrow> trm"      ("$\<phi>")
| Not "formula"            ("!")
| And "formula" "formula"    (infixl "&&" 8)
| Exists ident "formula"      ("\<^bold>\<exists>_. _")
(* \<langle>\<alpha>\<rangle>\<phi> iff exists run of \<alpha> where \<phi> is true in end state *)
| Diamond "hp" "formula"         ("(\<langle> _ \<rangle> _)" 10)
(* Contexts C are symbols standing for functions from (the semantics of) formulas to
 * (the semantics of) formulas, thus C(\<phi>) is another formula. While not necessary
 * in terms of expressiveness, contexts allow for more efficient reasoning principles. *)
| InContext ident "formula"

(* Derived forms *)
definition DFunl :: "ident \<Rightarrow> trm"
  where "DFunl fid = Function fid Var"

definition DPredl :: "ident \<Rightarrow> formula"
  where "DPredl fid = Prop fid Var"

definition Minus :: "trm \<Rightarrow> trm \<Rightarrow> trm"
  where "Minus \<theta>\<^sub>1 \<theta>\<^sub>2 = Plus \<theta>\<^sub>1 (Neg \<theta>\<^sub>2)"

definition Or :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixl "||" 7)
where "Or P Q = Not (And (Not P) (Not Q))"

definition Implies :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixr "\<rightarrow>" 10)
where "Implies P Q = Or Q (Not P)"

definition Equiv :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixl "\<leftrightarrow>" 10)
where "Equiv P Q = Or (And P Q) (And (Not P) (Not Q))"

definition Forall :: "ident \<Rightarrow> formula \<Rightarrow> formula" ("\<^bold>\<forall>_. _")
  where "Forall x P = Not (Exists x (Not P))"

definition Equals :: "trm \<Rightarrow> trm \<Rightarrow> formula" (infix "\<^bold>=" 50)
where "Equals \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Geq \<theta>' \<theta>))"

definition NotEquals :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where "NotEquals \<theta> \<theta>' = Not((Geq \<theta> \<theta>') && (Geq \<theta>' \<theta>))"

definition Greater :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where "Greater \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Not (Geq \<theta>' \<theta>)))"

definition Less :: "trm \<Rightarrow> trm \<Rightarrow> formula"
  where "Less \<theta> \<theta>' = ((Geq \<theta>' \<theta>) && (Not (Geq \<theta> \<theta>')))"

definition Le ::  "trm \<Rightarrow> trm \<Rightarrow> formula" (infix "\<^bold><" 50) where "Le = Less"
definition Ge ::  "trm \<Rightarrow> trm \<Rightarrow> formula" (infix "\<^bold>>" 50) where "Ge = Greater"

definition Leq :: "trm \<Rightarrow> trm \<Rightarrow> formula" (infix "\<^bold>\<le>" 50)
  where "Leq \<theta> \<theta>' = (Geq \<theta>' \<theta>)"

definition Box :: "hp \<Rightarrow> formula \<Rightarrow> formula" ("([[_]]_)" 10)
where "Box \<alpha> P = Not (Diamond \<alpha> (Not P))"

definition TT ::" formula"
where "TT = Geq \<^bold>0 \<^bold>0"

definition FF ::"formula"
where "FF = Geq \<^bold>0 (One)"

type_synonym sequent = "formula list * formula list"
(* Rule: assumptions, then conclusion *)
type_synonym rule = "sequent list * sequent"

(* silliness to enable proving disequality lemmas *)
primrec sizeF::"formula \<Rightarrow> nat"
  and   sizeP::"hp \<Rightarrow> nat"
where
  "sizeP (Pvar a) = 1"
| "sizeP (Assign x \<theta>) = 1"
| "sizeP (AssignAny _) = 1"
| "sizeP (DiffAssign x \<theta>) = 1"
| "sizeP (Test \<phi>) = Suc (sizeF \<phi>)"
| "sizeP (EvolveODE ODE \<phi>) = Suc (sizeF \<phi>)"
| "sizeP (Choice \<alpha> \<beta>) = Suc (sizeP \<alpha> + sizeP \<beta>)"
| "sizeP (Sequence \<alpha> \<beta>) = Suc (sizeP \<alpha> + sizeP \<beta>)"
| "sizeP (Loop \<alpha>) = Suc (sizeP \<alpha>)"
| "sizeF (Geq p q) = 1"
| "sizeF (Prop p args) = 1"
| "sizeF (Not p) = Suc (sizeF p)"
| "sizeF (And p q) = sizeF p + sizeF q"
| "sizeF (Exists x p) = Suc (sizeF p)"
| "sizeF (Diamond p q) = Suc (sizeP p + sizeF q)"
| "sizeF (InContext C \<phi>) = Suc (sizeF \<phi>)"

lemma sizeF_diseq:"sizeF p \<noteq> sizeF q \<Longrightarrow> p \<noteq> q" by auto

named_theorems "expr_diseq" "Structural disequality rules for expressions"
lemma [expr_diseq]:"p \<noteq> And p q" by(induction p, auto)
lemma [expr_diseq]:"q \<noteq> And p q" by(induction q, auto)
lemma [expr_diseq]:"p \<noteq> Not p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> Or p q" by(rule sizeF_diseq, auto simp add: Or_def)
lemma [expr_diseq]:"q \<noteq> Or p q" by(rule sizeF_diseq, auto simp add: Or_def)
lemma [expr_diseq]:"p \<noteq> Implies p q" by(rule sizeF_diseq, auto simp add: Implies_def Or_def)
lemma [expr_diseq]:"q \<noteq> Implies p q" by(rule sizeF_diseq, auto simp add: Implies_def Or_def)
lemma [expr_diseq]:"p \<noteq> Equiv p q" by(rule sizeF_diseq, auto simp add: Equiv_def Or_def)
lemma [expr_diseq]:"q \<noteq> Equiv p q" by(rule sizeF_diseq, auto simp add: Equiv_def Or_def)
lemma [expr_diseq]:"p \<noteq> Exists x p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> Diamond a p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> InContext C p" by(induction p, auto)

(* A predicational is like a context with no argument, i.e. a variable standing for a
 * state-dependent formula, given meaning by the interpretation. This differs from a predicate
 * because predicates depend only on their arguments (which might then indirectly depend on the state).
 * We encode a predicational as a context applied to a formula whose truth value is constant with
 * respect to the state (specifically, always true)*)
fun Predicational :: "ident \<Rightarrow> formula" ("Pc")
where "Predicational P = InContext P (Geq \<^bold>0 \<^bold>0)"

(* Abbreviations for common syntactic constructs in order to make axiom definitions, etc. more
 * readable. *)
(* "Empty" function argument tuple, encoded as tuple where all arguments assume a constant value. *)
definition empty::" ident \<Rightarrow> trm"
where "empty \<equiv> \<lambda>i. \<^bold>0"

(* Function argument tuple with (effectively) one argument, where all others have a constant value. *)
fun singleton :: "trm \<Rightarrow> (ident \<Rightarrow> trm)"
where "singleton t i = (if i = Ix then t else \<^bold>0)"

lemma expand_singleton:"singleton t = (\<lambda>i. (if i = Ix then t else \<^bold>0))"
  by auto

subsection \<open>Well-Formedness predicates\<close>
inductive dfree :: "trm \<Rightarrow> bool"
where
  dfree_Var: "dfree (Var i)"
| dfree_Const: "dfree (Const r)"
| dfree_Fun: "nonbase f \<Longrightarrow> \<^cancel>\<open>nonbase (debase i) \<Longrightarrow>\<close> ilength f < MAX_STR \<Longrightarrow> (\<forall>j. dfree (args j)) \<Longrightarrow> dfree (Function f args)"
| dfree_Plus: "dfree \<theta>\<^sub>1 \<Longrightarrow> dfree \<theta>\<^sub>2 \<Longrightarrow> dfree (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dfree_Neg: "dfree \<theta> \<Longrightarrow> dfree (Neg \<theta>)"
| dfree_Times: "dfree \<theta>\<^sub>1 \<Longrightarrow> dfree \<theta>\<^sub>2 \<Longrightarrow> dfree (Times \<theta>\<^sub>1 \<theta>\<^sub>2)"
(* regular functionals are not dfree because they can depend on differential state, that's what dfunctionals are for *)
(*| dfree_DFunctional: "dfree ($$F' fid)"*)

lemma dfree_Zero[simp]: "dfree \<^bold>0"
  unfolding Zero_def by (simp add: dfree_Const)

inductive_simps dfree_Functional_simps[simp]: "dfree (Functional F)"

inductive dsafe :: "trm \<Rightarrow> bool"
where
  dsafe_Var: "dsafe (Var i)"
| dsafe_Const: "dsafe (Const r)"
| dsafe_Fun: "nonbase f \<Longrightarrow> ilength f < MAX_STR \<Longrightarrow> (\<forall>j. dsafe (args j)) \<Longrightarrow> dsafe (Function f args)"(*nonbase (debase i) \<Longrightarrow> *)
(* | dsafe_DFunl: "dsafe ($$F' i)" *)
| dsafe_Funl: "nonbase i \<Longrightarrow> ilength i < MAX_STR \<Longrightarrow> dsafe ($$F i)"
| dsafe_Neg: "dsafe \<theta> \<Longrightarrow> dsafe (Neg \<theta>)"
| dsafe_Plus: "dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Times: "dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Times \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Div: "dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Div \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Diff: "dfree \<theta> \<Longrightarrow> dsafe (Differential \<theta>)"
| dsafe_DiffVar: "dsafe ($' i)"
| dsafe_Max :"dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Max \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Min :"dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Min \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Abs :"dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe (Abs \<theta>\<^sub>1)"

inductive dexec :: "trm \<Rightarrow> bool"
where
  dexec_Var: "dexec (Var i)"
| dexec_Const: "dexec (Const r)"
| dexec_Neg: "dexec \<theta> \<Longrightarrow> dexec (Neg \<theta>)"
| dexec_Plus: "dexec \<theta>\<^sub>1 \<Longrightarrow> dexec \<theta>\<^sub>2 \<Longrightarrow> dexec (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dexec_Times: "dexec \<theta>\<^sub>1 \<Longrightarrow> dexec \<theta>\<^sub>2 \<Longrightarrow> dexec (Times \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dexec_Div: "dexec \<theta>\<^sub>1 \<Longrightarrow> dexec \<theta>\<^sub>2 \<Longrightarrow> dexec (Div \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dexec_Max :"dexec \<theta>\<^sub>1 \<Longrightarrow> dexec \<theta>\<^sub>2 \<Longrightarrow> dexec (Max \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dexec_Min :"dexec \<theta>\<^sub>1 \<Longrightarrow> dexec \<theta>\<^sub>2 \<Longrightarrow> dexec (Min \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dexec_Abs :"dexec \<theta>\<^sub>1 \<Longrightarrow> dexec (Abs \<theta>\<^sub>1)"

(* Explictly-written variables that are bound by the ODE. Needed to compute whether
 * ODE's are valid (e.g. whether they bind the same variable twice) *)
fun ODE_dom::"ODE \<Rightarrow> ident set"
where
  "ODE_dom (OVar c d) =  {}"
| "ODE_dom (OSing x \<theta>) = {x}"
| "ODE_dom (OProd ODE1 ODE2) = ODE_dom ODE1 \<union> ODE_dom ODE2"

lemma ODE_dom_assoc:"ODE_dom (oprod ODE1 ODE2) = ODE_dom (OProd ODE1 ODE2)"
  apply(induction ODE1 arbitrary:ODE2)
  by(auto)

inductive osafe:: "ODE \<Rightarrow> bool"
where
  osafe_Var:"osafe (OVar c d)"
| osafe_Sing:"dfree \<theta> \<Longrightarrow> osafe (OSing x \<theta>)"
| osafe_Prod:"osafe ODE1 \<Longrightarrow> osafe ODE2 \<Longrightarrow> ODE_dom ODE1 \<inter> ODE_dom ODE2 = {} \<Longrightarrow> osafe (OProd ODE1 ODE2)"

lemma osafe_assoc:
  fixes ODE1 ODE2
  shows "osafe (OProd ODE1 ODE2) = osafe (oprod ODE1 ODE2)"
proof -
  have lr:"osafe (OProd ODE1 ODE2) \<Longrightarrow> osafe (oprod ODE1 ODE2)"
    apply(induction ODE1 arbitrary:ODE2)
       apply(auto)
    by (metis (no_types, lifting) ODE.distinct ODE.inject ODE_dom.simps ODE_dom_assoc Un_empty inf_sup_distrib1 inf_sup_distrib2 osafe.cases osafe_Prod)
  have rl:"osafe (oprod ODE1 ODE2) \<Longrightarrow> osafe (OProd ODE1 ODE2)"
    apply(induction ODE1 arbitrary:ODE2)
      apply(auto)
    by (metis (no_types, lifting) ODE.distinct ODE.inject ODE_dom.simps ODE_dom_assoc Un_empty inf_sup_distrib1 inf_sup_distrib2 osafe.cases osafe_Prod)
  show ?thesis using lr rl by (auto)
qed

(* Programs/formulas without any differential terms. This definition not currently used but may
 * be useful in the future. *)
inductive hpfree:: "hp \<Rightarrow> bool"
  and     ffree::  "formula \<Rightarrow> bool"
where
  "hpfree (Pvar x)"
| "dfree e \<Longrightarrow> hpfree (Assign x e)"
| "hpfree (AssignAny x)"
(* Differential programs allowed but not differential terms  *)
| "dfree e \<Longrightarrow> hpfree (DiffAssign x e)"
| "ffree P \<Longrightarrow> hpfree (Test P)"
(* Differential programs allowed but not differential terms  *)
| "osafe ODE \<Longrightarrow> ffree P \<Longrightarrow> hpfree (EvolveODE ODE P)"
| "hpfree a \<Longrightarrow> hpfree b \<Longrightarrow> hpfree (Choice a b )"
| "hpfree a \<Longrightarrow> hpfree b \<Longrightarrow> hpfree (Sequence a b)"
| "hpfree a \<Longrightarrow> hpfree (Loop a)"
| "ffree f \<Longrightarrow> ffree (InContext C f)"
| "(\<forall> arg. (arg \<in> range args \<longrightarrow> dfree arg)) \<Longrightarrow> ffree (Prop p args)"
| "ffree p \<Longrightarrow> ffree (Not p)"
| "ffree p \<Longrightarrow> ffree q \<Longrightarrow> ffree (And p q)"
| "ffree p \<Longrightarrow> ffree (Exists x p)"
| "hpfree a \<Longrightarrow> ffree p \<Longrightarrow> ffree (Diamond a p)"
| "ffree (Predicational P)"
| "dfree t1 \<Longrightarrow> dfree t2 \<Longrightarrow> ffree (Geq t1 t2)"

inductive hpsafe:: "hp \<Rightarrow> bool"
  and     fsafe::  "formula \<Rightarrow> bool"
where
   hpsafe_Pvar:"hpsafe (Pvar x)"
 | hpsafe_Assign:"dsafe e \<Longrightarrow> hpsafe (Assign x e)"
 | hpsafe_AssignAny:" hpsafe (AssignAny e)"
 | hpsafe_DiffAssign:"dsafe e \<Longrightarrow> hpsafe (DiffAssign x e)"
 | hpsafe_Test:"fsafe P \<Longrightarrow> hpsafe (Test P)"
 | hpsafe_Evolve:"osafe ODE \<Longrightarrow> fsafe P \<Longrightarrow> hpsafe (EvolveODE ODE P)"
 | hpsafe_Choice:"hpsafe a \<Longrightarrow> hpsafe b \<Longrightarrow> hpsafe (Choice a b )"
 | hpsafe_Sequence:"hpsafe a \<Longrightarrow> hpsafe b \<Longrightarrow> hpsafe (Sequence a b)"
 | hpsafe_Loop:"hpsafe a \<Longrightarrow> hpsafe (Loop a)"

 | fsafe_Geq:"dsafe t1 \<Longrightarrow> dsafe t2 \<Longrightarrow> fsafe (Geq t1 t2)"
 | fsafe_Prop:"nonbase p \<Longrightarrow> (\<forall>i. dsafe (args i)) \<Longrightarrow> fsafe (Prop p args)"
 | fsafe_Not:"fsafe p \<Longrightarrow> fsafe (Not p)"
 | fsafe_And:"fsafe p \<Longrightarrow> fsafe q \<Longrightarrow> fsafe (And p q)"
 | fsafe_Exists:"fsafe p \<Longrightarrow> fsafe (Exists x p)"
 | fsafe_Diamond:"hpsafe a \<Longrightarrow> fsafe p \<Longrightarrow> fsafe (Diamond a p)"
 | fsafe_InContext:"nonbase C \<Longrightarrow> ilength C < MAX_STR \<Longrightarrow> fsafe f \<Longrightarrow> fsafe (InContext C f)"

inductive hpexec:: "hp \<Rightarrow> bool"
  and     fexec::  "formula \<Rightarrow> bool"
where
   hpexec_Assign:"dexec e \<Longrightarrow> hpexec (Assign x e)"
 | hpexec_Test:"fexec P \<Longrightarrow> hpexec (Test P)"
 | hpexec_Choice:"hpexec a \<Longrightarrow> hpexec b \<Longrightarrow> hpexec (Choice a b )"
 | hpexec_Sequence:"hpexec a \<Longrightarrow> hpexec b \<Longrightarrow> hpexec (Sequence a b)"

 | fexec_Geq:"dexec t1 \<Longrightarrow> dexec t2 \<Longrightarrow> fexec (Geq t1 t2)"
 | fexec_Not:"fexec p \<Longrightarrow> fexec (Not p)"
 | fexec_And:"fexec p \<Longrightarrow> fexec q \<Longrightarrow> fexec (And p q)"

(* Auto-generated simplifier rules for safety predicates *)
inductive_simps
      dfree_Plus_simps[simp]: "dfree (Plus a b)"
  and dfree_Neg_simps[simp]: "dfree (Neg a)"
  and dfree_Times_simps[simp]: "dfree (Times a b)"
  and dfree_Max_simps[simp]: "dfree (Max a b)"
  and dfree_Min_simps[simp]: "dfree (Min a b)"
  and dfree_Abs_simps[simp]: "dfree (Abs a)"
  and dfree_Var_simps[simp]: "dfree (Var x)"
  and dfree_DiffVar_simps[simp]: "dfree (DiffVar x)"
  and dfree_Differential_simps[simp]: "dfree (Differential x)"
(*  and dfree_DFunl_simps[simp]: "dfree (DFunctional i)"*)
  and dfree_Fun_simps[simp]: "dfree (Function i args)"
  and dfree_Const_simps[simp]: "dfree (Const r)"
  and dfree_Div_simps[simp]: "dfree (Div a b)"

inductive_simps
      dsafe_Plus_simps[simp]: "dsafe (Plus a b)"
  and dsafe_Neg_simps[simp]: "dsafe (Neg a)"
  and dsafe_Times_simps[simp]: "dsafe (Times a b)"
  and dsafe_Div_simps[simp]: "dsafe (Div a b)"
  and dsafe_Max_simps[simp]: "dsafe (Max a b)"
  and dsafe_Min_simps[simp]: "dsafe (Min a b)"
  and dsafe_Abs_simps[simp]: "dsafe (Abs a)"
  and dsafe_Var_simps[simp]: "dsafe (Var x)"
  and dsafe_DiffVar_simps[simp]: "dsafe (DiffVar x)"
  and dsafe_Fun_simps[simp]: "dsafe (Function i args)"
  and dsafe_Funl_simps[simp]: "dsafe ($$F i)"
  and dsafe_Diff_simps[simp]: "dsafe (Differential a)"
  and dsafe_Const_simps[simp]: "dsafe (Const r)"

lemma dsafe_Zero[simp]: "dsafe \<^bold>0"
  by (auto simp: Zero_def)

lemma dsafe_One[simp]: "dsafe \<^bold>1"
  by (auto simp: One_def)

inductive_simps
      dexec_Plus_simps[simp]: "dexec (Plus a b)"
  and dexec_Neg_simps[simp]: "dexec (Neg a)"
  and dexec_Times_simps[simp]: "dexec (Times a b)"
  and dexec_Div_simps[simp]: "dexec (Div a b)"
  and dexec_Max_simps[simp]: "dexec (Max a b)"
  and dexec_Var_simps[simp]: "dexec (Var x)"
  and dexec_Const_simps[simp]: "dexec (Const r)"

inductive_simps
      osafe_OVar_simps[simp]:"osafe (OVar c d)"
  and osafe_OSing_simps[simp]:"osafe (OSing x \<theta>)"
  and osafe_OProd_simps[simp]:"osafe (OProd ODE1 ODE2)"

inductive_simps
      hpsafe_Pvar_simps[simp]: "hpsafe (Pvar a)"
  and hpsafe_Sequence_simps[simp]: "hpsafe (a ;; b)"
  and hpsafe_Loop_simps[simp]: "hpsafe (a**)"
  and hpsafe_ODE_simps[simp]: "hpsafe (EvolveODE ODE p)"
  and hpsafe_Choice_simps[simp]: "hpsafe (a \<union>\<union> b)"
  and hpsafe_Assign_simps[simp]: "hpsafe (Assign x e)"
  and hpsafe_AssignAny_simps[simp]: "hpsafe (AssignAny e)"
  and hpsafe_DiffAssign_simps[simp]: "hpsafe (DiffAssign x e)"
  and hpsafe_Test_simps[simp]: "hpsafe (? p)"

  and fsafe_Geq_simps[simp]: "fsafe (Geq t1 t2)"
  and fsafe_Prop_simps[simp]: "fsafe (Prop p args)"
  and fsafe_Not_simps[simp]: "fsafe (Not p)"
  and fsafe_And_simps[simp]: "fsafe (And p q)"
  and fsafe_Exists_simps[simp]: "fsafe (Exists x p)"
  and fsafe_Diamond_simps[simp]: "fsafe (Diamond a p)"
  and fsafe_Context_simps[simp]: "fsafe (InContext C p)"

inductive_simps
      hpexec_Sequence_simps[simp]: "hpexec (a ;; b)"
  and hpexec_Choice_simps[simp]: "hpexec (a \<union>\<union> b)"
  and hpexec_Assign_simps[simp]: "hpexec (Assign x e)"
  and hpexec_Test_simps[simp]: "hpexec (? p)"

  and fexec_Geq_simps[simp]: "fexec (Geq t1 t2)"
  and fexec_Not_simps[simp]: "fexec (Not p)"
  and fexec_And_simps[simp]: "fexec (And p q)"
  and fexec_Le_simps[simp]: "fexec (Le p q)"
  and fexec_Ge_simps[simp]: "fexec (Ge p q)"
  and fexec_Leq_simps[simp]: "fexec (Leq p q)"

fun Ssafe::"sequent \<Rightarrow> bool"
where Ssafe_def:"Ssafe S =((\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst S) \<longrightarrow> fsafe (nth (fst S) i))
                 \<and>(\<forall>i. i \<ge> 0 \<longrightarrow> i < length (snd S) \<longrightarrow> fsafe (nth (snd S) i)))"

lemma index_list_induct:
  fixes P and n :: nat
  assumes BC:"\<And>L. 0 < length L \<Longrightarrow> P L 0"
  assumes IH:"\<And>x xs i. (i < length xs \<Longrightarrow> P xs i \<Longrightarrow> P (x # xs) (Suc i))"
  assumes i:"n < length L"
  shows "P L n"
  using i
  apply(induction L arbitrary: n)
  subgoal for n using i BC[of "L"] by auto
  subgoal for x xs m
      apply(cases "m = 0")
    subgoal using BC[of "x # xs"] by auto
    using IH[of "m-1"] i  by auto
  done

lemma nth_member:"n < List.length L \<Longrightarrow> List.member L (List.nth L n)"
  apply(induction L, auto simp add: member_rec)
  by (metis in_set_member length_Cons nth_mem set_ConsD)

lemma member_nth:"List.member L x \<Longrightarrow> \<exists>n. n < List.length L \<and> x = (List.nth L n)"
  apply(induction L, auto simp add: member_rec)
  using in_set_member length_Cons nth_mem set_ConsD
  by auto

lemma member_nthE:"List.member L x \<Longrightarrow> (\<And>n.  (n < List.length L \<and> x = (List.nth L n)) \<Longrightarrow> P) \<Longrightarrow> P"
  using member_nth[of L x]  apply simp
  by(erule exE,auto)

lemma Ssafe_code[code]:
"Ssafe S =
 ((foldr (\<lambda> x acc. acc \<and> fsafe x) (fst S) True)
\<and> (foldr (\<lambda> x acc. acc \<and> fsafe x) (snd S) True))"
  apply(auto)
  subgoal
  proof -
    assume all:"\<forall>i<length (fst S). fsafe (fst S ! i)"
    have mem:"\<And>x. List.member (fst S) x \<Longrightarrow> fsafe x"
      apply(erule member_nthE)
      using all by (auto)
    have memimp:"\<And>L. (\<forall>x. List.member L x \<longrightarrow> fsafe x) \<Longrightarrow>  (foldr (\<lambda>x acc. acc \<and> fsafe x)  L True)"
      subgoal for L
        apply(induction L)
        by(auto simp add: member_rec)
      done
    show "foldr (\<lambda>x acc. acc \<and> fsafe x)  (fst S) True"
      using all mem memimp by auto
  qed
  proof -
    assume all:"\<forall>i<length (snd S). fsafe (snd S ! i)"
    have mem:"\<And>x. List.member (snd S) x \<Longrightarrow> fsafe x"
      apply(erule member_nthE)
      using all by (auto)
    have memimp:"\<And>L. (\<forall>x. List.member L x \<longrightarrow> fsafe x) \<Longrightarrow>  (foldr (\<lambda>x acc. acc \<and> fsafe x)  L True)"
      subgoal for L
        apply(induction L)
        by(auto simp add: member_rec)
      done
    show "foldr (\<lambda>x acc. acc \<and> fsafe x)  (snd S) True"
      using all mem memimp by auto
  next
    fix i
  assume fold:"foldr (\<lambda>x acc. acc \<and> fsafe x) (fst S) True"
  assume i:"i < length (fst S)"
  then have mem:"List.member (fst S) (fst S ! i)"
    using nth_member i by auto
  have memimp:"\<And>L x. (foldr (\<lambda>x acc. acc \<and> fsafe x)  L True) \<Longrightarrow>List.member L x \<Longrightarrow> fsafe x"
      subgoal for L
        apply(induction L)
        by(auto simp add: member_rec)
      done
  show "fsafe (fst S ! i)"
    using mem memimp  fold by auto
next
  fix i
  assume fold:"foldr (\<lambda>x acc. acc \<and> fsafe x) (snd S) True"
  assume i:"i < length (snd S)"
  then have mem:"List.member (snd S) (snd S ! i)"
    using nth_member i by auto
  have memimp:"\<And>L x. (foldr (\<lambda>x acc. acc \<and> fsafe x)  L True) \<Longrightarrow>List.member L x \<Longrightarrow> fsafe x"
      subgoal for L
        apply(induction L)
        by(auto simp add: member_rec)
      done
  show "fsafe (snd S ! i)"
    using mem memimp  fold by auto
qed

(*
lemma closeI_sub:"j < length \<Gamma> \<Longrightarrow> sublist (closeI \<Gamma> j) \<Gamma>"
proof -
  assume j:"j < length \<Gamma>"
  have imp:"j < length \<Gamma> \<Longrightarrow> sublist (closeI \<Gamma> j) \<Gamma>"
      apply(rule index_list_induct[of "(\<lambda> \<Gamma> j. sublist (closeI \<Gamma> j) \<Gamma>)"])
    subgoal for L by (auto simp add: sublist_def, cases L, auto simp add: member_rec)
    using j by(auto simp add: sublist_def member_rec j)
  then show ?thesis using j by auto
qed
*)
(* Basic reasoning principles about syntactic constructs, including inductive principles *)
lemma dfree_is_dsafe: "dfree \<theta> \<Longrightarrow> dsafe \<theta>"
  by (induction rule: dfree.induct) (auto intro: dsafe.intros)

lemma hp_induct [case_names Var Assign AssignAny DiffAssign Test Evolve Choice Compose Star]:
   "(\<And>x. P ($\<alpha> x)) \<Longrightarrow>
    (\<And>x1 x2. P (x1 := x2)) \<Longrightarrow>
    (\<And>x1. P (AssignAny x1 )) \<Longrightarrow>
    (\<And>x1 x2. P (DiffAssign x1 x2)) \<Longrightarrow>
    (\<And>x. P (? x)) \<Longrightarrow>
    (\<And>x1 x2. P (EvolveODE x1 x2)) \<Longrightarrow>
    (\<And>x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P (x1 \<union>\<union> x2)) \<Longrightarrow>
    (\<And>x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P (x1 ;; x2)) \<Longrightarrow>
    (\<And>x. P x \<Longrightarrow> P x**) \<Longrightarrow>
     P hp"
  by(induction rule: hp.induct) (auto)

lemma fml_induct:
  "(\<And>t1 t2. P (Geq t1 t2))
  \<Longrightarrow> (\<And>p args. P (Prop p args))
  \<Longrightarrow> (\<And>p. P p \<Longrightarrow> P (Not p))
  \<Longrightarrow> (\<And>p q. P p \<Longrightarrow> P q \<Longrightarrow> P (And p q))
  \<Longrightarrow> (\<And>x p. P p \<Longrightarrow> P (Exists x p))
  \<Longrightarrow> (\<And>a p. P p \<Longrightarrow> P (Diamond a p))
  \<Longrightarrow> (\<And>C p. P p \<Longrightarrow> P (InContext C p))
  \<Longrightarrow> P \<phi>"
  by (induction rule: formula.induct) (auto)

lemma proj_sing1:"(singleton \<theta> vid1) = \<theta>"
  by (auto)

lemma proj_sing2:"vid1 \<noteq> y  \<Longrightarrow> (singleton \<theta> y) = \<^bold>0"
  by (auto)

end


(*  Title:       An Example of a Cofinitary Group in Isabelle/HOL
    Author:      Bart.Kastermans at colorado.edu, 2009
    Maintainer:  Bart.Kastermans at colorado.edu
*)

theory CofGroups
imports Main "~~/src/HOL/Library/Nat_Bijection"
begin;

section {* Introduction *}

text {* Cofinitary groups have received a lot of attention in Set
Theory.  I will start by giving some references, that together give a
nice view of the area.  See also Kastermans \cite {Kques} for my view
of where the study of these groups (other than formalization) is
headed.  Starting work was done by Adeleke \cite {MR989749}, Truss
\cite {MR896533} and \cite {MR1683516}, and Koppelberg \cite
{MR709997}.  Cameron \cite {MR1367160} is a very nice survey.  There
is also work on cardinal invariants related to these groups and other
almost disjoint families, see e.g. Brendle, Spinas, and Zhang \cite
{MR1783921}, Hru{\v{s}}{\'a}k, Steprans, and Zhang \cite {MR1856740},
and Kastermans and Zhang \cite {KZ}.  Then there is also work on
constructions and descriptive complexity of these groups, see
e.g. Zhang \cite {MR1974545}, Gao and Zhang \cite {MR2370282}, and
Kastermans \cite {BK1} and \cite {BK2}.

In this note we work through formalizing a basic example of a
cofinitary group.  We want to achieve two things by working through
this example.  First how to formalize some proofs from basic
set-theoretic algebra, and secondly, to do some first steps in the
study of formalization of this area of set theory.  This is related to
the work of Paulson andGr{\polhk{a}}bczewski \cite {PG} on formalizing
set theory, our preference however is towards using Isar resulting in
a development more readable for ``normal'' mathematicians.

A \emph{cofinitary group} is a subgroup $G$ of the symmetric group on
$\mathbb{N}$ (in Isabelle @{term nat}) such that all non-identity
elements $g \in G$ have finitely many fixed points.  A simple example
of a cofinitary group is obtained by considering the group $G'$ a
subgroup of the symmetric group on $\mathbb {Z}$ (in Isabelle @{term
int} generated by the function @{term upOne} $:\mathbb {Z}
\rightarrow \mathbb {Z}$ defined by $k \mapsto k + 1$.  No element in
this group other than the identity has a fixed point.  Conjugating
this group by any bijection $\mathbb {Z} \rightarrow \N$ gives a
cofinitary group.

We will develop a workable definition of a cofinitary group (Section
\ref {sect:mainnotions}) and show that the group as described in the
previous paragraph is indeed cofinitary (this takes the whole paper,
but is all pulled together in Section \ref {sect:concl}).  Note:
formalizing the previous paragraph is all that is completed in this
note.

Since this note is also written to be read by the proverbial
``normal'' mathematician we will sometimes remark on notations as used
in Isabelle as they related to common notation.  We do expect this
proverbial mathematician to be somewhat flexible though.  He or she
will need to be flexible in reading, this is just like reading any
other article; part of reading is reconstructing.  *}

text {* We end this introduction with a quick overview of the paper.
In Section \ref {sect:mainnotions} we define the notion of cofinitary
group.  In Section \ref {sect:theFunction} we define the function
@{term upOne} and give some of its basic properties.  In Section \ref
{sect:setOFunc} we define the set @{term Ex1} which is the underlying
set of the group generated by @{term upOne}, there we also derive a
normal form theorem for the elements of this set.  In Section \ref
{sect:Ex1CofBij} we show all elements in @{term Ex1} are cofinitary
bijections (cofinitary here is used in the general meaning of having
finitely many fixed points).  In Section \ref {sect:Ex1Closed} we show
this set is closed under composition and inverse, in effect showing
that it is a ``cofinitary group'' (cofinitary group here is in quotes,
since we only define it for sets of permutations on the natural
numbers).  In Section \ref {sect:moveNN} we show the general theorem that
conjugating a permutation by a bijection does the expected thing to
the set of fixed points.  In Section \ref {sect:bijN} we define the
function @{term CONJ} that is conjugation by @{term ni_bij}
(a bijection from @{typ nat} to @{typ int}), show that
is acts well with respect to the group operations, use it to define
@{term Ex2} which is the underlying set of the cofinitary group we are
construction, and show the basic properties of @{term Ex2}.  Finally
in Section \ref {sect:concl} we quickly show that all the work in the
section before it combines to show that @{term Ex2} is a cofinitary
group. *};

section {* The Main Notions *}

text {* \label {sect:mainnotions} First we define the two main notions.

We write @{term S_inf} for the symmetric group on the natural numbers
(we do not define this as a group, only as the set of bijections). *}

definition S_inf :: "(nat \<Rightarrow> nat) set"
where
"S_inf = {f::(nat \<Rightarrow> nat). bij f}"

text {* Note here that @{term bij} @{term f} is the predicate that
@{term f} is a bijection.  This is common notation in Isabelle, a
predicate applied to an object.  Related to this @{term inj} @{term f}
means @{term f} is injective, and @{term surj} @{term f} means @{term
f} is surjective.

The same notation is used for functionn application.  Next we define a
function @{term Fix}, applying it to an object is also written by
juxtaposition. *}

text {* Given any function @{term f} we define @{term Fix} @{term f}
to be the set of fixed points for this function. *}

definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a set)"
where
"Fix f = { n . f(n) = n }"

text {* We then define a locale @{term CofinitaryGroup} that
represents the notion of a cofinitary group. An interpretation is
given by giving a set of functions $nat \rightarrow nat$ and showing
that it satisfies the identities the locale assumes.  A locale is a
way to collect together some information that can then later be used
in a flexible way (we will not make a lot of use of that here). *}

locale CofinitaryGroup =
  fixes
    dom :: "(nat \<Rightarrow> nat) set"
  assumes
    type_dom : "dom \<subseteq> S_inf" and
    id_com : "id \<in> dom" and
    mult_closed : "f \<in> dom \<and> g \<in> dom \<Longrightarrow> f \<circ> g \<in> dom" and
    inv_closed : "f \<in> dom \<Longrightarrow> inv f \<in> dom" and
    cofinitary : "f \<in> dom \<and> f \<noteq> id \<Longrightarrow> finite (Fix f)";

section {* The Function @{term upOne} *}

text {* \label{sect:theFunction} Here we define the function, @{term
upOne}, translation up by 1 and proof some of its basic properties.
*}

definition upOne :: "int \<Rightarrow> int"
where
"upOne n = n + 1";

declare upOne_def [simp] -- "automated tools can use the definition";

text {* First we show that this function is a bijection.  This is done
in the usual two parts; we show it is injective by showing from the
assumption that outputs on two numbers are equal that these two
numbers are equal.  Then we show it is surjective by finding the
number that maps to a given number. *}

lemma inj_upOne: "inj upOne"
by (rule Fun.injI, simp);

lemma surj_upOne: "surj upOne"
proof (unfold Fun.surj_def, rule)
  fix k::int
  show "\<exists>m. k = upOne m"
    by (rule exI[of "\<lambda>l. k = upOne l" "k - 1"], simp);
qed;

theorem bij_upOne: "bij upOne"
by (unfold bij_def, rule conjI [OF inj_upOne surj_upOne]);

text {* Now we show that the set of fixed points of @{term upOne}
is empty.  We show this in two steps, first we show that no number
is a fixed point, and then derive from this that the set of fixed
points is empty. *}

lemma no_fix_upOne: "upOne n \<noteq> n"
proof (rule notI)
  assume "upOne n = n"
  with upOne_def have "n+1 = n" by simp;
  thus False by auto;
qed;

theorem "Fix upOne = {}"
proof -
  from Fix_def[of upOne]
  have "Fix upOne = {n . upOne n = n}" by auto;
  with no_fix_upOne have "Fix upOne = {n . False}" by auto;
  with Set.empty_def show "Fix upOne = {}" by auto;
qed;

text {* Finally we derive the equation for the inverse of @{term
upOne}.  The rule we use references @{text Hilbert_Choice} since the @{term
inv} operator, the operator that gives an inverse of a function, is
defined using Hilbert's choice operator. *}

lemma inv_upOne_eq: "(inv upOne) (n::int) = n - 1"
proof -
  fix "n" :: int
  have "((inv upOne) \<circ> upOne) (n - 1) = (inv upOne) n" by simp;
  with inj_upOne and Hilbert_Choice.inv_o_cancel
    show "(inv upOne) n = n - 1" by auto;
qed;

text {* We can also show this quickly using Hilbert\_Choice.inv\_f\_eq
properly instantiated : @{thm Hilbert_Choice.inv_f_eq[of upOne "n - 1"
n, OF inj_upOne]}. *};

lemma "(inv upOne) n = n - 1";
by (rule Hilbert_Choice.inv_f_eq[of upOne "n - 1" n, OF inj_upOne], simp);

section {* The Set of Functions and Normal Forms *}

text {* \label {sect:setOFunc} We define the set @{term Ex1} of all
powers of @{term upOne} and study some of its properties, note that
this is the group generated by @{term upOne} (in Section \ref
{sect:Ex1Closed} we prove it closed under composition and inverse).
In Section \ref {sect:Ex1CofBij} we show that all its elements are
cofinitary and bijections (bijections with finitely many fixed
points).  Note that this is not a cofinitary group, since our
definition requires the group to be a subset of @{term S_inf} *}

inductive_set Ex1 :: "(int \<Rightarrow> int) set" where
base_func: "upOne \<in> Ex1" |
comp_func: "f \<in> Ex1 \<Longrightarrow> (upOne \<circ> f) \<in> Ex1" |
comp_inv : "f \<in> Ex1 \<Longrightarrow> ((inv upOne) \<circ> f) \<in> Ex1";

text {* We start by showing a \emph{normal form} for elements in this
set. *}

lemma Ex1_Normal_form_part1: "f \<in> Ex1 \<Longrightarrow> \<exists>k. \<forall> n. f(n) = n + k";
proof (rule Ex1.induct [of "f"], blast);
    -- "blast takes care of the first goal which is formal noise"
  assume "f \<in> Ex1";
  have "\<forall>n. upOne n = n + 1" by simp;
  with HOL.exI show "\<exists>k. \<forall>n. upOne n = n + k" by auto;
next
  fix fa:: "int => int"
  assume fa_k: "\<exists>k. \<forall>n. fa n = n + k"
  thus "\<exists>k. \<forall>n. (upOne \<circ> fa) n = n + k" by auto;
next
  fix fa :: "int \<Rightarrow> int"
  assume fa_k: "\<exists>k. \<forall>n. fa n = n + k"
  from inv_upOne_eq have "\<forall>n. (inv upOne) n = n - 1" by auto;
  with fa_k show "\<exists>k. \<forall>n. (inv upOne \<circ> fa) n = n + k" by auto;
qed;

text {* Now we'll show the other direction.  Then we apply rule @{text
int_induct} which allows us to do the induction by first showing it
true for $k = 1$, then showing that if true for $k = i$ it is also
true for $k = i+1$ and finally showing that if true for $k = i$ then
it is also true for $k = i - 1$.

All proofs are fairly straightforward and use extensionality for
functions.  In the base case we are just dealing with @{term upOne}.
In the other cases we define the function @{text ?h} which satisfies
the induction hypothesis.  Then @{term f} is obtained from this by
adding or subtracting one pointwise.

In this proof we use some pattern matching to save on writing.  In the
statement of the theorem, we match the theorem against @{text "?P k"} thereby
defining the predicate @{text "?P"}. *}

lemma Ex1_Normal_form_part2:
  "(\<forall>f. ((\<forall>n. f n = n + k) \<longrightarrow> f \<in> Ex1))" (is "?P k");
proof (rule int_induct [of "?P" 1])
  show "\<forall>f. (\<forall>n. f n = n + 1) \<longrightarrow> f \<in> Ex1";
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + 1) \<longrightarrow> f \<in> Ex1";
    proof
      assume "\<forall>n. f n = n + 1"
      hence "\<forall>n. f n = upOne n" by auto;
      with fun_eq_iff[of f upOne,THEN sym]
         have "f = upOne" by auto;
      with Ex1.base_func show "f \<in> Ex1" by auto;
    qed
  qed;
next
  fix i::int
  assume "1 \<le> i"
  assume induct_hyp: "\<forall>f. (\<forall>n. f n = n + i) \<longrightarrow> f \<in> Ex1"
  show "\<forall>f. (\<forall>n. f n = n + (i + 1)) \<longrightarrow> f \<in> Ex1";
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + (i + 1)) \<longrightarrow> f \<in> Ex1"
    proof
      assume f_eq: "\<forall>n. f n = n + (i + 1)"
      let ?h = "\<lambda>n. n + i";
      from induct_hyp have h_Ex1: "?h \<in> Ex1" by auto;
      from  f_eq have "\<forall>n. f n = upOne (?h n)" by (unfold upOne_def,auto);;
      hence "\<forall>n. f n = (upOne \<circ> ?h) n" by auto;
      with fun_eq_iff[THEN sym, of f "upOne \<circ> ?h"]
         have "f = upOne \<circ> ?h" by auto;
      with h_Ex1 and Ex1.comp_func[of ?h] show "f \<in> Ex1" by auto;
    qed;
  qed;
next;
  fix i::int
  assume "i \<le> 1"
  assume induct_hyp: "\<forall>f. (\<forall>n. f n = n + i) \<longrightarrow> f \<in> Ex1"
  show "\<forall>f. (\<forall>n. f n = n + (i - 1)) \<longrightarrow> f \<in> Ex1";
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + (i - 1)) \<longrightarrow> f \<in> Ex1"
    proof
      assume f_eq: "\<forall>n. f n = n + (i - 1)"
      let ?h = "\<lambda>n. n + i";
      from  induct_hyp have h_Ex1: "?h \<in> Ex1" by auto;
      from inv_upOne_eq and f_eq
        have "\<forall>n. f n = (inv upOne) (?h n)" by auto;
      hence "\<forall>n. f n = (inv upOne \<circ> ?h) n" by auto;
      with fun_eq_iff[THEN sym, of f "inv upOne \<circ> ?h"]
         have "f = inv upOne \<circ> ?h" by auto;
      with h_Ex1 and Ex1.comp_inv[of ?h] show "f \<in> Ex1" by auto;
    qed;
  qed;
qed;

text {* Combining the two directions we get the normal form
theorem. *}

theorem Ex1_Normal_form: "(f \<in> Ex1) = (\<exists>k. \<forall>n. f(n) = n + k)";
proof
  assume "f \<in> Ex1"
  with Ex1_Normal_form_part1 [of f]
    show "(\<exists>k. \<forall>n. f(n) = n + k)" by auto;
next;
  assume "\<exists>k. \<forall>n. f(n) = n + k"
  with Ex1_Normal_form_part2
    show "f \<in> Ex1" by auto;
qed;

section {* All Elements Cofinitary Bijections. *};

text {* \label {sect:Ex1CofBij} We now show all elements in @{term
Ex1} are bijections, Theorem @{term all_bij}, and have no fixed
points, Theorem @{term no_fixed_pt}. *}

theorem all_bij: "f \<in> Ex1 \<Longrightarrow> bij f"
proof (unfold bij_def);
  assume "f \<in> Ex1"
  with Ex1_Normal_form
    obtain k where f_eq:"\<forall>n. f n = n + k" by auto;

  show "inj f \<and> surj f"
  proof (rule conjI)
    show INJ: "inj f"
    proof (rule injI)
      fix n m
      assume "f n = f m"
      with f_eq have "n + k = m + k" by auto;
      thus "n = m" by auto;
    qed;
  next;

    show SURJ: "surj f"
    proof (unfold Fun.surj_def, rule allI)
      fix n
      from f_eq have "n = f (n - k)" by auto;
      thus "\<exists>m. n = f m" by (rule exI);
    qed;
  qed;
qed;

theorem no_fixed_pt:
  assumes f_Ex1: "f \<in> Ex1"
  and f_not_id: "f \<noteq> id"
  shows "Fix f = {}";
proof -
    -- "we start by proving an easy general fact"
  have f_eq_then_id: "(\<forall>n. f(n) = n) \<Longrightarrow> f = id"
  proof -
    assume f_prop : "\<forall>n. f(n) = n"
    have "(f x = id x) = (f x = x)" by simp;
    hence "(\<forall>x. (f x = id x)) = (\<forall>x. (f x = x))" by simp;
    with fun_eq_iff[THEN sym, of f id] and f_prop show "f = id" by auto;
  qed;
  from f_Ex1 and Ex1_Normal_form have "\<exists>k. \<forall>n. f(n) = n + k" by auto;
  then obtain k where k_prop: "\<forall>n. f(n) = n + k" ..;
  hence "k = 0 \<Longrightarrow> \<forall>n. f(n) = n" by auto;
  with f_eq_then_id and f_not_id have "k \<noteq> 0" by auto;
  with k_prop have "\<forall>n. f(n) \<noteq> n" by auto;
  moreover
  from Fix_def[of f] have "Fix f = {n . f(n) = n}" by auto;
  ultimately have "Fix f = {n. False}" by auto;
  with Set.empty_def show "Fix f = {}" by auto;
qed;

section {* Closed under Composition and Inverse *}

text {* \label {sect:Ex1Closed} We start by showing that this set is
closed under composition.  These facts can later be conjugated to
easily obtain the corresponding results for the group on the natural
numbers. *}

theorem closed_comp: "f \<in> Ex1 \<and> g \<in> Ex1 \<Longrightarrow> f \<circ> g \<in> Ex1"
proof (rule Ex1.induct [of f], blast);
  assume "f \<in> Ex1 \<and> g \<in> Ex1";
  with Ex1.comp_func[of g] show "upOne \<circ> g \<in> Ex1" by auto;
next
  fix fa
  assume "fa \<circ> g \<in> Ex1"
  with Ex1.comp_func [of "fa \<circ> g"]
    and Fun.o_assoc [of "upOne" "fa" "g"]
    show "upOne \<circ> fa \<circ> g \<in> Ex1" by auto;
next
  fix fa
  assume "fa \<circ> g \<in> Ex1"
  with Ex1.comp_inv [of "fa \<circ> g"]
    and Fun.o_assoc [of "inv upOne" "fa" "g"]
    show "(inv upOne) \<circ> fa \<circ> g \<in> Ex1" by auto;
qed;

text {* Now we show the set is closed under inverses.  This is
done by an induction on the definition of @{term Ex1} only using
the normal form theorem and rewriting of expressions. *}

theorem closed_inv: "f \<in> Ex1 \<Longrightarrow> inv f \<in> Ex1"
proof (rule Ex1.induct [of "f"], blast);
  assume "f \<in> Ex1"
  show "inv upOne \<in> Ex1" (is "?right \<in> Ex1")
  proof -
    let ?left  = "inv upOne \<circ> (inv upOne \<circ> upOne)"
    {
      from Ex1.comp_inv and Ex1.base_func have "?left \<in> Ex1" by auto;
    }
    moreover
    {
      from bij_upOne and bij_is_inj have "inj upOne" by auto;
      hence "inv upOne \<circ> upOne = id" by auto;
      hence "?left = ?right" by auto;
    }
    ultimately
    show ?thesis by auto;
  qed;
next
  fix f
  assume f_Ex1: "f \<in> Ex1";
  from f_Ex1 and Ex1_Normal_form
  obtain k where f_eq: "\<forall>n. f n = n + k" by auto;

  show "inv (upOne \<circ> f) \<in> Ex1"
  proof -
    let ?ic = "inv (upOne \<circ> f)"
    let ?ci = "inv f \<circ> inv upOne";
    {
      -- "first we get an expression for @{term ?ci}"
      {
        from all_bij and f_Ex1 have "bij f" by auto;
        with bij_is_inj have inj_f: "inj f" by auto;
        have "\<forall>n. inv f n = n - k"
        proof
          fix n
          from f_eq have "f (n - k) = n"; by auto;
          with inv_f_eq[of f "n-k" "n"] and inj_f
          show "inv f n = n-k"; by auto;
        qed;
        with inv_upOne_eq
        have "\<forall>n. ?ci n = n - k - 1" by auto;
        hence "\<forall>n. ?ci n = n + (-1 - k)" by arith;
      }
      moreover;
      -- "then we check that this implies @{term ?ci} is"
      -- "a member of @{term Ex1}";
      {
        from Ex1_Normal_form_part2[of "-1 - k"]
        have "(\<forall>f. ((\<forall>n. f n = n + (-1 - k)) \<longrightarrow> f \<in> Ex1))" by auto;
      }
      ultimately
      have "?ci \<in> Ex1"; by auto;
    }
    moreover
    {
      from f_Ex1 all_bij have "bij f" by auto;
      with bij_upOne and o_inv_distrib[THEN sym]
      have "?ci = ?ic" by auto;
    }
    ultimately show ?thesis by auto;
  qed;
next;
  fix f
  assume f_Ex1: "f \<in> Ex1";
  with Ex1_Normal_form
    obtain k where f_eq: "\<forall>n. f n = n + k" by auto;

  show "inv (inv upOne \<circ> f) \<in> Ex1"
  proof -
    let ?ic = "inv (inv upOne \<circ> f)"
    let ?c = "inv f \<circ> upOne"
    {
      from all_bij and f_Ex1 have "bij f" by auto;
      with bij_is_inj have inj_f: "inj f" by auto;
      have "\<forall>n. inv f n = n - k"
      proof
        fix n
        from f_eq have "f (n - k) = n"; by auto;
        with inv_f_eq[of f "n-k" "n"] and inj_f
        show "inv f n = n-k"; by auto;
      qed;
      with upOne_def
      have "\<forall>n. (inv f \<circ> upOne) n = n - k + 1" by auto;
      hence "\<forall>n. (inv f \<circ> upOne) n = n + (1 - k)" by arith;
      moreover
      from Ex1_Normal_form_part2[of "1 - k"]
      have "(\<forall>f. ((\<forall>n. f n = n + (1 - k)) \<longrightarrow> f \<in> Ex1))" by auto;
      ultimately
      have "?c \<in> Ex1"; by auto;
    }
    moreover
    {
      from f_Ex1 all_bij and bij_is_inj have "bij f" by auto;
      moreover
      from bij_upOne and bij_imp_bij_inv have "bij (inv upOne)" by auto;
      moreover
      note o_inv_distrib[THEN sym];
      ultimately
      have "inv f \<circ> inv (inv upOne) = inv (inv upOne \<circ> f)" by auto;
      moreover
      from bij_upOne and inv_inv_eq
        have "inv (inv upOne) = upOne" by auto;
      ultimately
      have "?c = ?ic" by auto;
    }
    ultimately
    show ?thesis by auto;
  qed;
qed;

section {* Conjugation with a Bijection *}

text {* \label {sect:moveNN} An abbreviation of the bijection from the
natural numbers to the integers defined in the library.  This will be
used to coerce the functions above to be on the natural numbers. *}

abbreviation "ni_bij == int_decode"

lemma bij_f_o_inf_f: "bij f \<Longrightarrow> f \<circ> inv f = id"
  unfolding bij_def surj_iff by simp

text {* The following theorem is a key theorem in showing that the
group we are interested in is cofinitary.  It states that when you
conjugate a function with a bijection the fixed points get mapped
over. *}

theorem conj_fix_pt: "\<And>f::('a \<Rightarrow> 'b). \<And>g::('b \<Rightarrow> 'b). (bij f)
  \<Longrightarrow> ((inv f)`(Fix g)) = Fix ((inv f) \<circ> g \<circ> f)";
proof -
  fix f::"'a \<Rightarrow> 'b"
  assume bij_f: "bij f"
  with bij_def have inj_f: "inj f" by auto;
  fix g::"'b\<Rightarrow>'b"
  show "((inv f)`(Fix g)) = Fix ((inv f) \<circ> g \<circ> f)";
  thm set_eq_subset[of "(inv f)`(Fix g)" "Fix((inv f) \<circ> g \<circ> f)"]
  proof
    show "(inv f)`(Fix g) \<subseteq> Fix ((inv f) \<circ> g \<circ> f)"
    proof
      fix x
      assume "x \<in> (inv f)`(Fix g)"
      with image_def have "\<exists>y \<in> Fix g. x = (inv f) y" by auto;
      from this obtain y where y_prop: "y \<in> Fix g \<and> x = (inv f) y" by auto;
      hence "x = (inv f) y" ..;
      hence "f x = (f \<circ> inv f) y" by auto;
      with bij_f and bij_f_o_inf_f[of f] have f_x_y: "f x = y" by auto;
      from y_prop have "y \<in> Fix g" ..;
      with Fix_def[of g] have "g y = y" by auto;
      with f_x_y have "g (f x) = f x" by auto;
      hence "(inv f) (g (f x)) = inv f (f x)" by auto;
      with inv_f_f and inj_f have "(inv f) (g (f x)) = x" by auto;
      hence "((inv f) \<circ> g \<circ> f) x = x" by auto;
      with Fix_def[of "inv f \<circ> g \<circ> f"]
        show "x \<in> Fix ((inv f) \<circ> g \<circ> f)" by auto;
    qed;
  next
    show "Fix (inv f \<circ> g \<circ> f) \<subseteq> (inv f)`(Fix g)"
    proof
      fix x
      assume "x \<in> Fix (inv f \<circ> g \<circ> f)"
      with Fix_def[of "inv f \<circ> g \<circ> f"]
        have x_fix: "(inv f \<circ> g \<circ> f) x = x" by auto;
      hence "(inv f) (g(f(x))) = x" by auto;
      hence "\<exists>y. (inv f) y = x" by auto;
      from this obtain y where x_inf_f_y: "x = (inv f) y" by auto;
      with x_fix have "(inv f \<circ> g \<circ> f)((inv f) y) = (inv f) y" by auto;
      hence "(f \<circ> inv f \<circ> g \<circ> f \<circ> inv f) (y) = (f \<circ> inv f)(y)" by auto;
      with o_assoc
        have "((f \<circ> inv f) \<circ> g \<circ> (f \<circ> inv f)) y = (f \<circ> inv f)y" by auto;
      with bij_f and bij_f_o_inf_f[of f]
        have "g y = y" by auto;
      with Fix_def[of g] have "y \<in> Fix g" by auto;
      with x_inf_f_y show "x \<in> (inv f)`(Fix g)" by auto;
    qed
  qed;
qed;

section {* Bijections on $\mathbb{N}$ *}

text {* \label {sect:bijN} In this section we define the subset @{term
Ex2} of @{term S_inf} that is the conjugate of @{term Ex1} bij @{term
ni_bij}, and show its basic properties.

@{term CONJ} is the function that will conjugate @{term Ex1} to @{term Ex2}. *}

definition CONJ :: "(int \<Rightarrow> int) \<Rightarrow> (nat \<Rightarrow> nat)"
where
"CONJ f = (inv ni_bij) \<circ> f \<circ> ni_bij";

declare CONJ_def [simp] -- "automated tools can use the definition";

text {* We quickly check that this function is of the right type, and
then show three of its properties that are very useful in showing
@{term Ex2} is a group. *}

lemma type_CONJ: "f \<in> Ex1 \<Longrightarrow> (inv ni_bij) \<circ> f \<circ> ni_bij \<in> S_inf"
proof -
  assume f_Ex1: "f \<in> Ex1"
  with all_bij have "bij f" by auto;
  with bij_int_decode and bij_comp
    have bij_f_nibij: "bij (f \<circ> ni_bij)" by auto;
  with bij_int_decode and bij_imp_bij_inv have "bij (inv ni_bij)" by auto;
  with bij_f_nibij and bij_comp[of  "f \<circ> ni_bij" "inv ni_bij"]
    and o_assoc[of "inv ni_bij" "f" "ni_bij"]
    have "bij ((inv ni_bij) \<circ> f \<circ> ni_bij)" by auto;
  with S_inf_def show "((inv ni_bij) \<circ> f \<circ> ni_bij) \<in> S_inf"; by auto;
qed;

lemma inv_CONJ:
  assumes bij_f: "bij f"
  shows "inv (CONJ f) = CONJ (inv f)" (is "?left = ?right")
proof -
  have st1: "?left = inv ((inv ni_bij) \<circ> f \<circ> ni_bij)"
    using CONJ_def by auto;
  from bij_int_decode and bij_imp_bij_inv
    have inv_ni_bij_bij: "bij (inv ni_bij)" by auto;
  with bij_f and bij_comp have "bij (inv ni_bij \<circ> f)" by auto;
  with o_inv_distrib[of "inv ni_bij \<circ> f" ni_bij] and bij_int_decode
  have "inv ((inv ni_bij) \<circ> f \<circ>  ni_bij) =
    (inv ni_bij) \<circ> (inv ((inv ni_bij) \<circ> f))" by auto;
  with st1 have st2: "?left =
    (inv ni_bij) \<circ> (inv ((inv ni_bij) \<circ> f))" by auto;
  from inv_ni_bij_bij and `bij f` and o_inv_distrib
    have h1: "inv (inv ni_bij \<circ> f) = inv f \<circ> inv (inv (ni_bij))" by auto;
  from bij_int_decode and inv_inv_eq[of ni_bij]
    have "inv (inv ni_bij) = ni_bij" by auto;
  with st2 and h1 have "?left = (inv ni_bij \<circ> (inv f \<circ> ( ni_bij)))" by auto;
  with o_assoc have "?left = inv ni_bij \<circ> inv f \<circ> ni_bij" by auto;
  with CONJ_def[of "inv f"] show ?thesis by auto;
qed;

lemma comp_CONJ:
  "CONJ (f \<circ> g) = (CONJ f) \<circ> (CONJ g)" (is "?left = ?right")
proof -;
  from bij_int_decode have "surj ni_bij" unfolding bij_def by auto;
  then have "ni_bij \<circ> (inv ni_bij) = id" unfolding surj_iff by auto;
  moreover
  have "?left = (inv ni_bij) \<circ> (f \<circ> g) \<circ> ni_bij" by simp;
  hence "?left = (inv ni_bij) \<circ> ((f \<circ> id) \<circ> g) \<circ> ni_bij" by simp;
  ultimately
  have "?left =
    (inv ni_bij) \<circ> ((f \<circ> (ni_bij \<circ> (inv ni_bij))) \<circ> g) \<circ> ni_bij"
    by auto;
      -- "a simple computation using only associativity"
      -- "completes the proof"
  thus "?left = ?right" by (auto simp add: o_assoc);
qed;

lemma id_CONJ: "CONJ id = id";
proof (unfold CONJ_def)
  from bij_int_decode have "inj ni_bij" using bij_def by auto;
  hence "inv ni_bij \<circ> ni_bij = id" by auto;
  thus "(inv ni_bij \<circ> id) \<circ> ni_bij = id" by auto;
qed;

text {* We now define the group we are interested in, and show the
basic facts that together will show this is a cofinitary group. *}

definition Ex2 :: "(nat \<Rightarrow> nat) set"
where
"Ex2 = CONJ`Ex1";

theorem mem_Ex2_rule: "f \<in> Ex2 = (\<exists>g. (g \<in> Ex1 \<and> f = CONJ g))"
proof
  assume "f \<in> Ex2"
  hence "f \<in> CONJ`Ex1" using Ex2_def by auto;
  from this obtain "g" where "g \<in> Ex1 \<and> f = CONJ g" by blast;
  thus "\<exists>g. (g \<in> Ex1 \<and> f = CONJ g)" by auto;
next;
  assume "\<exists>g. (g \<in> Ex1 \<and> f = CONJ g)"
  with Ex2_def show "f \<in> Ex2" by auto;
qed;

theorem Ex2_cofinitary:
  assumes f_Ex2: "f \<in> Ex2"
  and f_nid: "f \<noteq> id"
  shows "Fix f = {}";
proof -
  from f_Ex2 and mem_Ex2_rule
  obtain g where g_Ex1: "g \<in> Ex1" and f_cg: "f = CONJ g" by auto;
  with id_CONJ and f_nid have "g \<noteq> id" by auto;
  with g_Ex1 and no_fixed_pt[of g] have fg_empty: "Fix g = {}" by auto;
  from conj_fix_pt[of ni_bij g] and bij_int_decode
  have "(inv ni_bij)`(Fix g) = Fix(CONJ g)" by auto;
  with fg_empty have "{} = Fix (CONJ g)" by auto;
  with f_cg show "Fix f = {}" by auto;
qed;

lemma id_Ex2: "id \<in> Ex2"
proof -
  from Ex1_Normal_form_part2[of "0"] have "id \<in> Ex1" by auto;
  with id_CONJ and Ex2_def and mem_Ex2_rule show ?thesis by auto;
qed;

lemma inv_Ex2: "f \<in> Ex2 \<Longrightarrow> (inv f) \<in> Ex2"
proof -
  assume "f \<in> Ex2"
  with mem_Ex2_rule obtain "g" where "g \<in> Ex1" and "f = CONJ g"; by auto;
  with closed_inv have "inv g \<in> Ex1" by auto;
  from `f = CONJ g` have if_iCg: "inv f = inv (CONJ g)" by auto;
  from all_bij and `g \<in> Ex1` have "bij g" by auto;
  with if_iCg and inv_CONJ have "inv f = CONJ (inv g)" by auto;
  from `g \<in> Ex1` and "closed_inv" have "inv g \<in> Ex1" by auto;
  with `inv f = CONJ (inv g)` and mem_Ex2_rule show "inv f \<in> Ex2" by auto;
qed;

lemma comp_Ex2:
  assumes f_Ex2: "f \<in> Ex2" and
  g_Ex2: "g \<in> Ex2"
  shows "f \<circ> g \<in> Ex2"
proof -
  from f_Ex2 obtain f_1
    where f_1_Ex1: "f_1 \<in> Ex1" and "f = CONJ f_1"
    using mem_Ex2_rule by auto;
  moreover
  from g_Ex2 obtain g_1
    where g_1_Ex1: "g_1 \<in> Ex1" and "g = CONJ g_1"
    using mem_Ex2_rule by auto;
  ultimately
  have "f \<circ> g = (CONJ f_1) \<circ> (CONJ g_1)" by auto;
  hence "f \<circ> g = CONJ (f_1 \<circ> g_1)" using comp_CONJ by auto;
  moreover
  have "f_1 \<circ> g_1 \<in> Ex1" using closed_comp and f_1_Ex1 and g_1_Ex1 by auto;
  ultimately
  show "f \<circ> g \<in> Ex2" using mem_Ex2_rule by auto;
qed;

section {* The Conclusion *}

text {* \label{sect:concl} With all that we have shown we have already
clearly shown @{term Ex2} to be a cofinitary group.  The formalization
also shows this, we just have to refer to the correct theorems proved
above. *}

interpretation CofinitaryGroup Ex2;
proof;
  show "Ex2 \<subseteq> S_inf"
  proof;
    fix f
    assume "f \<in> Ex2"
    with mem_Ex2_rule obtain g where "g \<in> Ex1" and "f = CONJ g" by auto;
    with type_CONJ show "f \<in> S_inf" by auto;
  qed;
next
  from id_Ex2 show "id \<in> Ex2" .;
next
  fix f g
  assume "f \<in> Ex2 \<and> g \<in> Ex2"
  with comp_Ex2 show "f \<circ> g \<in> Ex2"; by auto;
next
  fix f
  assume "f \<in> Ex2"
  with inv_Ex2 show "inv f \<in> Ex2" by auto;
next;
  fix f
  assume "f \<in> Ex2 \<and> f \<noteq> id"
  with Ex2_cofinitary have "Fix f = {}" by auto;
  thus "finite (Fix f)" using finite_def by auto;
qed;

end;


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

section \<open>Implementation of mappings with Association Lists\<close>

theory AList_Mapping
  imports AList Mapping
begin

lift_definition Mapping :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" is map_of .

code_datatype Mapping

lemma lookup_Mapping [simp, code]: "Mapping.lookup (Mapping xs) = map_of xs"
  by transfer rule

lemma keys_Mapping [simp, code]: "Mapping.keys (Mapping xs) = set (map fst xs)"
  by transfer (simp add: dom_map_of_conv_image_fst)

lemma empty_Mapping [code]: "Mapping.empty = Mapping []"
  by transfer simp

lemma is_empty_Mapping [code]: "Mapping.is_empty (Mapping xs) \<longleftrightarrow> List.null xs"
  by (cases xs) (simp_all add: is_empty_def null_def)

lemma update_Mapping [code]: "Mapping.update k v (Mapping xs) = Mapping (AList.update k v xs)"
  by transfer (simp add: update_conv')

lemma delete_Mapping [code]: "Mapping.delete k (Mapping xs) = Mapping (AList.delete k xs)"
  by transfer (simp add: delete_conv')

lemma ordered_keys_Mapping [code]:
  "Mapping.ordered_keys (Mapping xs) = sort (remdups (map fst xs))"
  by (simp only: ordered_keys_def keys_Mapping sorted_list_of_set_sort_remdups) simp

lemma size_Mapping [code]: "Mapping.size (Mapping xs) = length (remdups (map fst xs))"
  by (simp add: size_def length_remdups_card_conv dom_map_of_conv_image_fst)

lemma tabulate_Mapping [code]: "Mapping.tabulate ks f = Mapping (map (\<lambda>k. (k, f k)) ks)"
  by transfer (simp add: map_of_map_restrict)

lemma bulkload_Mapping [code]:
  "Mapping.bulkload vs = Mapping (map (\<lambda>n. (n, vs ! n)) [0..<length vs])"
  by transfer (simp add: map_of_map_restrict fun_eq_iff)

lemma equal_Mapping [code]:
  "HOL.equal (Mapping xs) (Mapping ys) \<longleftrightarrow>
    (let ks = map fst xs; ls = map fst ys
     in (\<forall>l\<in>set ls. l \<in> set ks) \<and> (\<forall>k\<in>set ks. k \<in> set ls \<and> map_of xs k = map_of ys k))"
proof -
  have *: "(a, b) \<in> set xs \<Longrightarrow> a \<in> fst ` set xs" for a b xs
    by (auto simp add: image_def intro!: bexI)
  show ?thesis
    apply transfer
    apply (auto intro!: map_of_eqI)
     apply (auto dest!: map_of_eq_dom intro: *)
    done
qed

lemma map_values_Mapping [code]:
  "Mapping.map_values f (Mapping xs) = Mapping (map (\<lambda>(x,y). (x, f x y)) xs)"
  for f :: "'c \<Rightarrow> 'a \<Rightarrow> 'b" and xs :: "('c \<times> 'a) list"
  apply transfer
  apply (rule ext)
  subgoal for f xs x by (induct xs) auto
  done

lemma combine_with_key_code [code]:
  "Mapping.combine_with_key f (Mapping xs) (Mapping ys) =
     Mapping.tabulate (remdups (map fst xs @ map fst ys))
       (\<lambda>x. the (combine_options (f x) (map_of xs x) (map_of ys x)))"
  apply transfer
  apply (rule ext)
  apply (rule sym)
  subgoal for f xs ys x
    apply (cases "map_of xs x"; cases "map_of ys x"; simp)
       apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
        dest: map_of_SomeD split: option.splits)+
    done
  done

lemma combine_code [code]:
  "Mapping.combine f (Mapping xs) (Mapping ys) =
     Mapping.tabulate (remdups (map fst xs @ map fst ys))
       (\<lambda>x. the (combine_options f (map_of xs x) (map_of ys x)))"
  apply transfer
  apply (rule ext)
  apply (rule sym)
  subgoal for f xs ys x
    apply (cases "map_of xs x"; cases "map_of ys x"; simp)
       apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
        dest: map_of_SomeD split: option.splits)+
    done
  done

lemma map_of_filter_distinct:  (* TODO: move? *)
  assumes "distinct (map fst xs)"
  shows "map_of (filter P xs) x =
    (case map_of xs x of
      None \<Rightarrow> None
    | Some y \<Rightarrow> if P (x,y) then Some y else None)"
  using assms
  by (auto simp: map_of_eq_None_iff filter_map distinct_map_filter dest: map_of_SomeD
      simp del: map_of_eq_Some_iff intro!: map_of_is_SomeI split: option.splits)

lemma filter_Mapping [code]:
  "Mapping.filter P (Mapping xs) = Mapping (filter (\<lambda>(k,v). P k v) (AList.clearjunk xs))"
  apply transfer
  apply (rule ext)
  apply (subst map_of_filter_distinct)
   apply (simp_all add: map_of_clearjunk split: option.split)
  done

lemma [code nbe]: "HOL.equal (x :: ('a, 'b) mapping) x \<longleftrightarrow> True"
  by (fact equal_refl)

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, implemented iterators, min, max, to_sorted_list

*)

section {* \isaheader{Set Implementation by Red-Black-Tree} *}
theory RBTSetImpl
imports
  "../spec/SetSpec"
  "RBTMapImpl"
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw {*\label{thy:RBTSetImpl}*}
(*@impl Set
  @type ('a::linorder) rs
  @abbrv rs,r
  Sets over linearly ordered elements implemented by red-black trees.
*)

subsection "Definitions"
type_synonym
  'a rs = "('a::linorder,unit) rm"

setup Locale_Code.open_block
interpretation rs_sbm: OSetByOMap rm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition rs_ops :: "('x::linorder,'x rs) oset_ops"
  where [icf_rec_def]: "rs_ops \<equiv> rs_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation rs: StdOSetDefs rs_ops .
interpretation rs: StdOSet rs_ops
  unfolding rs_ops_def
  by (rule rs_sbm.obasic.dflt_oops_impl)

interpretation rs: StdSet_no_invar rs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "rs"*}

lemmas rbt_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_rm]
  it_to_it_map_fold'[OF pi_rm_rev]

lemma pi_rs[proper_it]:
  "proper_it' rs.iteratei rs.iteratei"
  "proper_it' rs.iterateoi rs.iterateoi"
  "proper_it' rs.rev_iterateoi rs.rev_iterateoi"
  unfolding rs.iteratei_def[abs_def] rs.iterateoi_def[abs_def]
    rs.rev_iterateoi_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation
  pi_rs: proper_it_loc rs.iteratei rs.iteratei +
  pi_rs_o: proper_it_loc rs.iterateoi rs.iterateoi +
  pi_rs_ro: proper_it_loc rs.rev_iterateoi rs.rev_iterateoi
  by unfold_locales (rule pi_rs)+

definition test_codegen where "test_codegen \<equiv> (
  rs.empty,
  rs.memb,
  rs.ins,
  rs.delete,
  rs.list_it,
  rs.sng,
  rs.isEmpty,
  rs.isSng,
  rs.ball,
  rs.bex,
  rs.size,
  rs.size_abort,
  rs.union,
  rs.union_dj,
  rs.diff,
  rs.filter,
  rs.inter,
  rs.subset,
  rs.equal,
  rs.disjoint,
  rs.disjoint_witness,
  rs.sel,
  rs.to_list,
  rs.from_list,

  rs.ordered_list_it,
  rs.rev_list_it,
  rs.min,
  rs.max,
  rs.to_sorted_list,
  rs.to_rev_list
)"

export_code test_codegen in SML

end