theory Locales_For_Macintyre
  imports Padic_Cells
begin

(**************************************************************************************************)
(**************************************************************************************************)
section\<open>Defining Locales for Proving Macintyre's Theorem\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>Many of the lemmas required for Macintyre's Theorem have complex proof contexts which are
interrelated to each other. This section defines various locales to provide these contexts and make
their relationships to one another explicit.\<close>

(**************************************************************************************************)
(**************************************************************************************************)
subsection\<open>\<open>Locales for the Cell Decomposition Theorem Conclusions\<close>\<close>
(**************************************************************************************************)
(**************************************************************************************************)

text\<open>Denef's Cell Decomposition Theorems $I$ and $II$ both assert that the set $\mathbb{Q}_p^{m+1}$
can be decomposed into $p$-adic cells such that one or more $p$-adic polynomials are well-behaved on
each cell. The locales \texttt{SA\_poly\_ubounded} and \texttt{SA\_poly\_factors} express these
notions of well-behavedness. \texttt{SA\_poly\_ubounded} formalizes the conclusion of Denef's cell
decomposition theorem $I$, while \texttt{SA\_poly\_factors} expresses the conclusion of theorem $II$.
\<close>

locale SA_poly_ubounded = padic_fields +
  fixes n P c A N
  assumes P_closed: "P \<in> carrier (UP (SA n))"
  assumes c_closed: "c \<in> carrier (SA n)"
  assumes A_closed: "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes ubounded: "\<And> x t. t#x \<in> A \<Longrightarrow>val ((SA_poly_to_Qp_poly n x P)\<bullet> t) \<le>
                           val ((UPQ.taylor_term (c x) (SA_poly_to_Qp_poly n x P) i)\<bullet>t) + eint N"

locale SA_poly_factors  = padic_fields +
  fixes n::nat and  m::nat and  P::padic_nary_function_poly and
        c:: padic_nary_function and  A::"padic_tuple set" and
        u:: padic_nary_function and  h:: padic_nary_function  and  k::nat
  assumes h_closed: "h \<in> carrier (SA n)"
  assumes c_closed: "c \<in> carrier (SA n)"
  assumes u_closed: "u \<in> (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<rightarrow> carrier Q\<^sub>p)"
  assumes A_closed: "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes u_val: "\<And> x t. \<lbrakk> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>); t \<in> carrier Q\<^sub>p; t#x \<in> A\<rbrakk>
                               \<Longrightarrow>   val (u (t#x)) = 0"
  assumes factors: "\<And> x t. \<lbrakk> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>); t \<in> carrier Q\<^sub>p; t#x \<in> A\<rbrakk> \<Longrightarrow>
    (SA_poly_to_Qp_poly n x P)\<bullet> t = ((u (t#x))[^] m)\<otimes>(h x)\<otimes> (t \<ominus> (c x))[^] k"

context padic_fields
begin

lemma SA_poly_uboundedI:
  assumes "f \<in> carrier (UP (SA n))"
  assumes "c \<in> carrier (SA n)"
  assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes "\<And> x t i. t#x \<in> A \<Longrightarrow>
              val ( (SA_poly_to_Qp_poly n x f)\<bullet> t) \<le>  val ((UPQ.taylor_term (c x) (SA_poly_to_Qp_poly n x f) i)\<bullet>t) + eint N"
  shows "SA_poly_ubounded p n f c A N "
  apply(intro SA_poly_ubounded.intro, intro padic_fields_axioms)
  using assms unfolding SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def by auto

lemma SA_poly_uboundedE:
  assumes "P \<in> carrier (UP (SA n))"
  assumes "c \<in> carrier (SA n)"
  assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes "t#x \<in> A"
  assumes "\<exists> N. SA_poly_ubounded p n P c A N"
  shows "\<exists>N. val ( (SA_poly_to_Qp_poly n x P)\<bullet> t) \<le>  val ((UPQ.taylor_term (c x) (SA_poly_to_Qp_poly n x P) i)\<bullet>t) + eint N"
  using assms
  unfolding SA_poly_ubounded_def SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def
  by blast

text\<open>When A is a cell with center c, whether Ps are bounded on A is independent of the choice of c\<close>

text\<open>Boundedness of a semialgebraic polynomial on a cell decomposition\<close>
definition is_compatible_decomp where
"is_compatible_decomp n S P \<equiv> is_cell_decomp n S (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) \<and>
                              (\<forall>s \<in> S.  \<exists>N. SA_poly_ubounded p n P (center s) (condition_to_set s) N)"

lemma is_compatible_decompI:
  assumes "P \<in> carrier (UP (SA n))"
  assumes "is_cell_decomp n S (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>))"
  assumes "\<And>s. s \<in> S \<Longrightarrow>  \<exists>N. SA_poly_ubounded p n P (center s) (condition_to_set s) N"
  shows "is_compatible_decomp n S P"
  using assms is_compatible_decomp_def
  by blast

text\<open>Factoring a semialgebraic polynomial by a semialgebraic power\<close>

lemma SA_poly_factors_closure:
  assumes "SA_poly_factors p n m P c A u h k"
  shows "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
        "u \<in> (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<rightarrow> carrier Q\<^sub>p)"
        "c \<in> carrier (SA n)"
        "h \<in> carrier (SA n)"
        "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<Longrightarrow> u x \<in> carrier Q\<^sub>p"
  using assms
  unfolding SA_poly_factors_def SA_poly_factors_axioms_def Q\<^sub>p_def Z\<^sub>p_def
  by auto

lemma SA_poly_factorsE:
  assumes "SA_poly_factors p n m P c A u h k"
  assumes "t#x \<in> A"
  shows "val (u (t#x)) = 0"
        "(SA_poly_to_Qp_poly n x P)\<bullet> t = (((u (t#x))[^] m)\<otimes>(h x)\<otimes> (t \<ominus> (c x)) [^] k)"
        "(u (t#x)) \<in> carrier Q\<^sub>p"
        "(u (t#x)) \<noteq> \<zero>"
        "(u (t#x)) \<in> nonzero Q\<^sub>p"
proof-
  have 0: "t#x \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
    using assms SA_poly_factors_closure(1)
    by blast
  have 1:"x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
    using 0 assms cartesian_power_tail[of "t#x" Q\<^sub>p n ]
    by (metis list.sel(3))
  have 2: "t \<in> carrier Q\<^sub>p"
    using 0 cartesian_power_head[of "t#x" Q\<^sub>p n]
    by (metis list.sel(1))
  show 3: "val (u (t#x)) = 0"
    apply(intro SA_poly_factors.u_val[of p n m P c A u h k] assms(1))
    using 1 2 assms unfolding Q\<^sub>p_def  Z\<^sub>p_def  by auto
  show "(SA_poly_to_Qp_poly n x P)\<bullet> t = (((u (t#x)) [^] m)\<otimes>(h x)\<otimes> (t \<ominus> (c x)) [^] k)"
    using assms 0 1 2
    unfolding SA_poly_factors_def SA_poly_factors_axioms_def Q\<^sub>p_def  Z\<^sub>p_def
    by auto
  show 4: "u (t # x) \<in> carrier Q\<^sub>p"
    using assms SA_poly_factors_closure by blast
  show 5: "u (t # x) \<noteq> \<zero>"
    using 3 val_def infinity_ne_i0 by metis
  show " u (t # x) \<in> nonzero Q\<^sub>p"
    by(rule nonzero_memI, rule 4, rule 5)
qed

lemma SA_poly_factorsI:
  assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes "u \<in> (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<rightarrow> carrier Q\<^sub>p)"
  assumes "c \<in> carrier (SA n)"
  assumes "h \<in> carrier (SA n)"
  assumes "\<And>x t. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> t \<in> carrier Q\<^sub>p \<Longrightarrow> t#x \<in> A \<Longrightarrow> val (u (t#x)) = 0 \<and>
                                       (SA_poly_to_Qp_poly n x P)\<bullet> t = (((u (t#x))[^] m)\<otimes>(h x)\<otimes> (t \<ominus> (c x))[^] k)"
  shows "SA_poly_factors p n m P c A u h k"
  apply(intro SA_poly_factors.intro padic_fields_axioms SA_poly_factors_axioms.intro)
  using assms unfolding Q\<^sub>p_def Z\<^sub>p_def by auto

lemma SA_poly_factorsI':
  assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
  assumes "u \<in> (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<rightarrow> carrier Q\<^sub>p)"
  assumes "c \<in> carrier (SA n)"
  assumes "h \<in> carrier (SA n)"
  assumes "\<And>x t. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> t \<in> carrier Q\<^sub>p \<Longrightarrow> t#x \<in> A \<Longrightarrow> val (u (t#x)) = 0"
  assumes "\<And>x t. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> t \<in> carrier Q\<^sub>p \<Longrightarrow> t#x \<in> A \<Longrightarrow> (SA_poly_to_Qp_poly n x P)\<bullet> t = (((u (t#x))[^] m)\<otimes>(h x)\<otimes> (t \<ominus> (c x))[^] k)"
  shows "SA_poly_factors p n m P c A u h k"
  by(intro SA_poly_factorsI assms conjI, auto)

lemma SA_poly_ubounded_facts:
  assumes "\<exists>N. SA_poly_ubounded p m f c A N"
  shows "f \<in> carrier (UP (SA m))"
        "c \<in> carrier (SA m)"
        "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
  using assms  unfolding SA_poly_ubounded_def SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def by auto

lemma SA_poly_ubounded_facts':
  assumes "SA_poly_ubounded p m f c A N"
  shows "f \<in> carrier (UP (SA m))"
        "c \<in> carrier (SA m)"
        "A \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
  using assms unfolding SA_poly_ubounded_def SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def by auto

lemma SA_poly_uboundedE':
  assumes "SA_poly_ubounded p m f c A N"
  shows " \<forall>x t i.
            t # x \<in> A \<longrightarrow>
            val (SA_poly_to_Qp_poly m x f \<bullet> t) \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint N"
  using assms  unfolding SA_poly_ubounded_def unfolding SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def
  by blast

lemma SA_poly_uboundedE'':
  assumes "\<exists>N. SA_poly_ubounded p m f c A N"
  shows " \<exists>N. \<forall>x t i.
            t # x \<in> A \<longrightarrow>
            val (SA_poly_to_Qp_poly m x f \<bullet> t) \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint N"
  using assms SA_poly_uboundedE  unfolding SA_poly_ubounded_def SA_poly_ubounded_axioms_def Q\<^sub>p_def Z\<^sub>p_def
  by metis

lemma SA_poly_uboundedE''':
  assumes "\<exists>N. SA_poly_ubounded p m f c A N"
  shows "\<exists>N::nat. (\<forall>x t i. t # x \<in> A \<longrightarrow> val (SA_poly_to_Qp_poly m x f \<bullet> t) \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + N)"
proof(cases "A = {}")
  case True
  then show ?thesis by blast
next
  case False
  obtain N::int where N_def: "(\<forall>x t i. t # x \<in> A \<longrightarrow> val (SA_poly_to_Qp_poly m x f \<bullet> t) \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint N)"
    using assms SA_poly_uboundedE' by blast
  obtain k::nat where k_def: "k \<ge> N"
    apply(cases "N < 0")
     apply force
    by (metis verit_comp_simplify(2) verit_comp_simplify(3) zero_le_imp_eq_int)
  then have "eint k \<ge> eint N"
    by simp
  hence 0: "\<And> x t i. val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint N \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint k"
    by (meson add_left_mono)
  hence 1: "(\<forall>x t i. t # x \<in> A \<longrightarrow> val (SA_poly_to_Qp_poly m x f \<bullet> t) \<le> val (UPQ.taylor_term (c x) (SA_poly_to_Qp_poly m x f) i \<bullet> t) + eint k)"
    using N_def
    by (meson eint_ord_trans)
  thus ?thesis by blast
qed
end

(**************************************************************************************************)
(**************************************************************************************************)
subsubsection \<open>Denef's Facts $I_d$ and $II_d$\<close>
(**************************************************************************************************)
(**************************************************************************************************)
(**************************************************************************************************)

locale denef_I = padic_fields +
  fixes d::nat
  assumes cell_decomp: "\<And>m P.\<lbrakk> P \<in> carrier (UP (SA m)); deg (SA m) P \<le> d \<rbrakk> \<Longrightarrow>
                      \<exists> S. (is_cell_decomp m S (carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)) \<and>
                      (\<forall>A \<in> S. \<exists>N. SA_poly_ubounded p m P (center A) (condition_to_set A) N))"

locale denef_II = padic_fields +
  fixes d::nat
  assumes cell_decomp: "\<And>n m Ps.\<lbrakk> finite Ps \<and>
                                  (\<forall>P \<in> Ps. P \<in> carrier (UP (SA n)) \<and>  deg (SA n) P \<le> d) \<and> m > 0 \<rbrakk> \<Longrightarrow>

                            (\<exists> S. (is_cell_decomp n S (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) \<and>
                           (\<forall>A \<in> S. \<forall>P \<in> Ps. \<exists>u h k. SA_poly_factors p n m P (center A) (condition_to_set A) u h k)))"

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Map Implementation by Association Lists with explicit invariants} *}
theory ListMapImpl_Invar
imports
  "../spec/MapSpec"
  "../../Lib/Assoc_List"
  "../gen_algo/MapGA"
begin
text_raw {*\label{thy:ListMapImpl_Invar}*}

(*@impl Map
  @type 'a lmi
  @abbrv lmi,l
  Maps implemented by associative lists. Version with explicit
  invariants that allows for efficient xxx-dj operations.
*)

type_synonym ('k,'v) lmi = "('k\<times>'v) list"

term revg

definition "lmi_\<alpha> \<equiv> Map.map_of"
definition "lmi_invar \<equiv> \<lambda>m. distinct (List.map fst m)"

definition lmi_basic_ops :: "('k,'v,('k,'v) lmi) map_basic_ops"
  where [icf_rec_def]: "lmi_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = lmi_\<alpha>,
  bmap_op_invar = lmi_invar,
  bmap_op_empty = (\<lambda>_::unit. []),
  bmap_op_lookup = (\<lambda>k m. Map.map_of m k),
  bmap_op_update = AList.update,
  bmap_op_update_dj = (\<lambda>k v m. (k, v) # m),
  bmap_op_delete = AList.delete_aux,
  bmap_op_list_it = foldli
\<rparr>"

setup Locale_Code.open_block
interpretation lmi_basic: StdBasicMapDefs lmi_basic_ops .
interpretation lmi_basic: StdBasicMap lmi_basic_ops
  unfolding lmi_basic_ops_def
  apply unfold_locales
  apply (simp_all
    add: icf_rec_unf lmi_\<alpha>_def lmi_invar_def
    add: AList.update_conv' AList.distinct_update AList.map_of_delete_aux'
      map_iterator_foldli_correct dom_map_of_conv_image_fst
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lmi_ops \<equiv> lmi_basic.dflt_ops \<lparr>
  map_op_add_dj := revg,
  map_op_to_list := id,
  map_op_size := length,
  map_op_isEmpty := case_list True (\<lambda>_ _. False),
  map_op_isSng := (\<lambda>l. case l of [_] \<Rightarrow> True | _ \<Rightarrow> False)
\<rparr>"

setup Locale_Code.open_block
interpretation lmi: StdMapDefs lmi_ops .
interpretation lmi: StdMap lmi_ops
proof -
  interpret aux: StdMap lmi_basic.dflt_ops by (rule lmi_basic.dflt_ops_impl)

  have [simp]: "map_add_dj lmi_\<alpha> lmi_invar revg"
    apply (unfold_locales)
    apply (auto simp: lmi_\<alpha>_def lmi_invar_def)
    apply (blast intro: map_add_comm)
    apply (simp add: rev_map[symmetric])
    apply fastforce
    done

  have [simp]: "map_to_list lmi_\<alpha> lmi_invar id"
    apply unfold_locales
    by (simp_all add: lmi_\<alpha>_def lmi_invar_def)

  have [simp]: "map_isEmpty lmi_\<alpha> lmi_invar (case_list True (\<lambda>_ _. False))"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    by (simp split: list.split)

  have [simp]: "map_isSng lmi_\<alpha> lmi_invar
     (\<lambda>l. case l of [_] \<Rightarrow> True | _ \<Rightarrow> False)"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    apply (auto split: list.split)
    apply (metis (no_types) map_upd_nonempty)
    by (metis fun_upd_other fun_upd_same option.simps(3))

  have [simp]: "map_size_axioms lmi_\<alpha> lmi_invar length"
    apply unfold_locales
    unfolding lmi_\<alpha>_def lmi_invar_def
    by (metis card_dom_map_of)

  show "StdMap lmi_ops"
    unfolding lmi_ops_def
    apply (rule StdMap_intro)
    apply (simp_all)
    apply intro_locales
    apply (simp_all add: icf_rec_unf)
    done
qed
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lmi"*}

lemma pi_lmi[proper_it]:
  "proper_it' foldli foldli"
  by (intro proper_it'I icf_proper_iteratorI)

interpretation pi_lmi: proper_it_loc foldli foldli
  apply unfold_locales
  apply (rule pi_lmi)
  done

definition lmi_from_list_dj :: "('k\<times>'v) list \<Rightarrow> ('k,'v) lmi" where
  "lmi_from_list_dj \<equiv> id"

lemma lmi_from_list_dj_correct:
  assumes [simp]: "distinct (map fst l)"
  shows "lmi.\<alpha> (lmi_from_list_dj l) = map_of l"
        "lmi.invar (lmi_from_list_dj l)"
  by (auto simp add: lmi_from_list_dj_def icf_rec_unf lmi_\<alpha>_def lmi_invar_def)

text {* Code generator test *}
definition "test_codegen \<equiv> (
  lmi.add ,
  lmi.add_dj ,
  lmi.ball ,
  lmi.bex ,
  lmi.delete ,
  lmi.empty ,
  lmi.isEmpty ,
  lmi.isSng ,
  lmi.iterate ,
  lmi.iteratei ,
  lmi.list_it ,
  lmi.lookup ,
  lmi.restrict ,
  lmi.sel ,
  lmi.size ,
  lmi.size_abort ,
  lmi.sng ,
  lmi.to_list ,
  lmi.to_map ,
  lmi.update ,
  lmi.update_dj,
  lmi_from_list_dj
  )"

export_code test_codegen in SML

end


chapter "Deterministic State Monad with Failure"

theory Det_Monad
imports
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/While_Combinator"
  "../Monad_WP/wp/WP"
  SP
begin

section "Basic Monad Definitions"

type_synonym ('s,'a) det_monad = "'s \<Rightarrow> 'a \<times> 's \<times> bool"

definition
  bind :: "('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> ('s,'b) det_monad) \<Rightarrow> ('s,'b) det_monad"
where
  "bind f g \<equiv> \<lambda>s. let (r', s', f') = f s;
                       (r'', s'', f'') = g r' s'
                   in (r'', s'', f' \<or> f'')"

definition
  "return x \<equiv> \<lambda>s. (x, s, False)"

(* use do-notation for this state monad *)
adhoc_overloading
  Monad_Syntax.bind bind

(* always print do-notation *)
translations
  "CONST bind_do" == "CONST Monad_Syntax.bind"

section "State Monad Definitions"

definition
  "get \<equiv> \<lambda>s. (s, s, False)"

definition
  "put s \<equiv> \<lambda>s'. ((), s, False)"

definition
  "fail \<equiv> \<lambda>s. ((), s, True)"

section "Derived Monad Definitions"

definition
  "modify f \<equiv> get >>= (\<lambda>x. put (f x))"

definition
  "gets f \<equiv> get >>= (\<lambda>x. return (f x))"

definition
  "assert P \<equiv> if P then return () else fail"

definition
  "state_assert P \<equiv> do { s \<leftarrow> get; assert (P s) }"

definition
  while_body :: "('a \<Rightarrow> ('s, 'a) det_monad) \<Rightarrow> 'a \<times> 's \<times> bool \<Rightarrow> 'a \<times> 's \<times> bool"
where
  "while_body b \<equiv> \<lambda>(rv,s,f). let (rv',s',f') = b rv s in (rv',s',f \<or> f')"

definition
  "whileLoop_opt g b \<equiv> while_option (g o fst) (while_body b)"

definition
  whileLoop :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s, 'a) det_monad) \<Rightarrow> 'a \<Rightarrow> ('s,'a) det_monad"
where
  "whileLoop g b \<equiv> \<lambda>x s. case whileLoop_opt g b (x, s, False) of
                            Some r \<Rightarrow> r
                          | None \<Rightarrow> (undefined, undefined, True)"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

lemma while_body_aux:
  "(while_body b ^^ k) (x, s, f) =
      (fst ((while_body b ^^ k) (x, s, f')),
       fst (snd ((while_body b ^^ k) (x, s, f'))),
       if \<not>f'
       then f \<or> snd (snd ((while_body b ^^ k) (x, s, f')))
       else snd (snd ((while_body b ^^ k) (x, s, f)))
      )"
proof (induct k)
  case 0 thus ?case by clarsimp
next
  case (Suc n)
  show ?case
    apply (clarsimp split del: if_split)
    apply (subst Suc.hyps)
    apply (clarsimp simp: while_body_def split: prod.splits)
    using Suc.hyps
    apply (clarsimp simp: while_body_def split: prod.splits)
    done
qed

lemma least_while_body_guard:
  "(LEAST k. \<not> g (fst ((while_body b ^^ k) (x, s, f)))) =
   (LEAST k. \<not> g (fst ((while_body b ^^ k) (x, s, f'))))"
  by (subst while_body_aux) simp

lemma whileLoop_opt_Some:
  "whileLoop_opt g b (x, s, f) = Some (x', s', f')
  \<Longrightarrow> whileLoop_opt g b (x, s, f'') = Some (x', s', if \<not>f then f'' \<or> f' else
      snd (snd (the (whileLoop_opt g b (x, s, f'')))))"
  unfolding whileLoop_opt_def Let_def
  apply (clarsimp simp: while_option_def split: if_split_asm)
  apply (rule conjI)
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (subst least_while_body_guard[where f'=f])
    apply (subst while_body_aux[where f=f'' and f'=f])
    apply simp
   apply (rule exI)
   apply (subst while_body_aux)
   apply simp
  apply clarsimp
  apply (rule conjI)
   apply clarsimp
   apply (subst least_while_body_guard[where f'=f])
   apply (subst while_body_aux[where f=f'' and f'=f])
   apply simp
   apply (subst least_while_body_guard[where f=True and f'=f''])
   apply simp
  apply (rule exI)
  apply (subst while_body_aux)
  apply simp
  done

lemma while_body_apply[simp]:
  "while_body b (r, s, f) = (fst (b r s), fst (snd (b r s)), f \<or> snd (snd (b r s)))"
  by (simp add: while_body_def split: prod.splits)

lemma whileLoop_unfold:
  "whileLoop g b x = (if g x then b x >>= whileLoop g b else return x)"
  unfolding whileLoop_def whileLoop_opt_def
  apply (rule ext)
  apply (rename_tac s)
  apply (subst while_option_unfold)
  apply (clarsimp simp: whileLoop_opt_def[symmetric] return_def bind_def split: prod.splits)
  apply (clarsimp split: option.splits)
   apply (drule whileLoop_opt_Some[where f''=False])
   apply clarsimp
  apply (drule_tac f''="snd (snd (b x s))" in whileLoop_opt_Some)
  apply clarsimp
  done

section "Hoare-Logic Validity"

text {* Partial correctness *}
definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (let (r',s',f') = m s in \<not>f' \<longrightarrow> Q r' s')"

text {* Total correctness *}
definition
  validNF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>! \<equiv> \<forall>s. P s \<longrightarrow> (let (r',s',f') = m s in Q r' s' \<and> \<not>f')"

text {* Unified correctness *}
definition
  validU :: "(('s \<times> bool)  \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> ('s \<times> bool) \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>u")
where
  "\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>u \<equiv> \<forall>s f. P (s,f) \<longrightarrow> (let (r',s',f') = m s in Q r' (s',f \<and> \<not>f'))"

section "Hoare-Logic Rules"

text \<open>Rule collections for weakest preconditions\<close>
named_theorems wp'
named_theorems wp_pre'

text \<open>Rule collections for strongest postconditions\<close>
named_theorems sp
named_theorems sp_pre

text {* Strongest postcondition method setup *}
method sp declares sp = ((((rule sp)+), (rule sp_pre, rule sp, assumption?)?)  |
                        (rule sp_pre, rule sp, assumption?))

lemma bind_wp[wp']:
  "(\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>) \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace> \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>"
  unfolding valid_def Let_def bind_def by (fastforce split: prod.splits)

lemma hoare_seq_ext[sp]:
  "\<lbrace>A\<rbrace> f \<lbrace>B \<rbrace> \<Longrightarrow> (\<And>x.\<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>) \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>"
  by (rule bind_wp)

lemma hoare_chain:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<And>s. R s \<Longrightarrow> P s; \<And>r s. Q r s \<Longrightarrow> S r s \<rbrakk> \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>"
  by (fastforce simp: valid_def)

lemma hoare_pre[wp_pre']:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>; \<And>s. R s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> \<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace>"
  by (rule hoare_chain) blast

lemmas hoare_weaken_pre = hoare_pre

lemma hoare_post[sp_pre]:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>; \<And>rv s. R rv s \<Longrightarrow> Q rv s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
  by (rule hoare_chain) blast

lemmas hoare_strengthen_post = hoare_post

lemma get_wp[wp']: "\<lbrace>\<lambda>s. P s s\<rbrace> get \<lbrace>P\<rbrace>"
  by (clarsimp simp: get_def valid_def)

lemma put_wp[wp']: "\<lbrace>\<lambda>s'. P () s\<rbrace> put s \<lbrace>P\<rbrace>"
  by (clarsimp simp: put_def valid_def)

lemma fail_wp[wp']: "\<lbrace>\<lambda>s. True\<rbrace> fail \<lbrace>P\<rbrace>"
  by (simp add: fail_def valid_def)

lemma return_wp[wp']: "\<lbrace>P x\<rbrace> return x \<lbrace>P\<rbrace>"
  by (simp add: valid_def return_def)

lemma if_wp[wp']:
  "\<lbrakk> Q \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>P\<rbrace>; \<not>Q \<Longrightarrow> \<lbrace>B\<rbrace> g \<lbrace>P\<rbrace>\<rbrakk> \<Longrightarrow>
  \<lbrace>\<lambda>s. (Q \<longrightarrow> A s) \<and> (\<not>Q \<longrightarrow> B s)\<rbrace> if Q then f else g \<lbrace>P\<rbrace>"
  by auto

lemma prod_wp[wp']:
  "(\<And>a b. x = (a,b) \<Longrightarrow> \<lbrace>P a b\<rbrace> f a b \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P (fst x) (snd x)\<rbrace> case x of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>"
  by (cases x) simp

lemma prod_sp[sp]:
  "(\<And>a b. x = (a,b) \<Longrightarrow> \<lbrace>P\<rbrace> f a b \<lbrace>Q a b\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> case x of (a, b) \<Rightarrow> f a b \<lbrace>Q (fst x) (snd x)\<rbrace>"
  by (cases x) simp

text {* Weakest precondition method setup *}
method wp uses wp = (rule wp_pre', WP.wp wp wp', assumption?)

(* partial correctness assumes asserts *)
lemma assert_wp[wp']:
  "\<lbrace>\<lambda>s. Q \<longrightarrow> P () s\<rbrace> assert Q \<lbrace>P\<rbrace>"
  unfolding assert_def by wp auto

lemma state_assert_wp[wp']:
  "\<lbrace>\<lambda>s. Q s \<longrightarrow> P () s\<rbrace> state_assert Q \<lbrace>P\<rbrace>"
  unfolding state_assert_def by wp

lemma modify_wp[wp']:
  "\<lbrace>\<lambda>s. P () (f s)\<rbrace> modify f \<lbrace>P\<rbrace>"
  unfolding modify_def by wp

lemma gets_wp[wp']:
  "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>"
  unfolding gets_def by wp

lemma whileLoop_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> g r \<rbrace> b r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> g r \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop g b r \<lbrace> Q \<rbrace>"
  unfolding whileLoop_def whileLoop_opt_def valid_def
  apply (clarsimp split: option.splits)
  apply (frule while_option_stop)
  apply (drule while_option_rule[where P="\<lambda>(r,s,f). \<not>f \<longrightarrow> I r s", rotated])
    apply simp
   apply (clarsimp simp: while_body_def split: prod.splits)
   apply (drule meta_spec)
   apply (erule allE)
   apply (erule impE, simp)
   apply simp
  apply simp
  done

definition
  whileLoop_inv :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) det_monad) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('s,'a) det_monad"
where
  "whileLoop_inv g b I \<equiv> whileLoop g b"

lemma whileLoop_add_inv: "whileLoop g b = whileLoop_inv g b I"
  by (clarsimp simp: whileLoop_inv_def)

lemma whileLoop_inv_wp[wp']:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> g r \<rbrace> b r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> g r \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop_inv g b I r \<lbrace> Q \<rbrace>"
  unfolding whileLoop_inv_def by (rule whileLoop_wp)

lemma return_sp[sp]:
  "\<lbrace>P\<rbrace> return x \<lbrace>\<lambda>rv s. rv = x \<and> P s\<rbrace>"
  by wp simp

lemma put_sp[sp]:
  "\<lbrace>R\<rbrace> put a \<lbrace>\<lambda>_ s. s = a \<rbrace>"
  by(simp add:put_def valid_def)

lemma put_sp'[sp]:
  "\<lbrace>\<lambda>_. R\<rbrace> put a \<lbrace>\<lambda>_ s. s = a \<and> R\<rbrace>"
  by(simp add:put_def valid_def)

lemma get_sp[sp]:
  "\<lbrace>P\<rbrace> get \<lbrace>\<lambda>a s. s = a \<and> P s\<rbrace>"
  by(simp add:get_def valid_def)

lemma assert_sp[sp]:
  "\<lbrace> P \<rbrace> assert Q \<lbrace> \<lambda>r s. P s \<and> Q \<rbrace>"
  by (simp add: assert_def fail_def return_def valid_def)

lemma hoare_gets_sp[sp]:
  "\<lbrace>P\<rbrace> gets f \<lbrace>\<lambda>rv s. rv = f s \<and> P s\<rbrace>"
  apply (simp add: gets_def, sp, clarsimp)
done

section "Total Correctness Rules"

lemma bind_wp_nf:
  "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>! \<Longrightarrow> (\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>!) \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>!"
    unfolding validNF_def Let_def bind_def by fastforce

section "Unified Correctness Rules"

lemma hoare_seq_extU[sp]:
  "\<lbrace>A\<rbrace> f \<lbrace>B \<rbrace>u \<Longrightarrow> (\<And>x.\<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>u)  \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>u"
  unfolding validU_def Let_def bind_def by fastforce

lemma hoare_chainU:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>u;
    \<And>s. R s \<Longrightarrow> P s;
    \<And>r s. Q r s \<Longrightarrow> S r s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>S\<rbrace>u"
  by (fastforce simp: validU_def)

lemma hoare_preU[wp_pre']:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>u;
    \<And>s. R s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow>
   \<lbrace>R\<rbrace> f \<lbrace>Q\<rbrace>u"
  by (fastforce simp: validU_def)

lemma hoare_postU[sp_pre]:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>R\<rbrace>u;
    \<And>rv s. R rv s \<Longrightarrow> Q rv s \<rbrakk> \<Longrightarrow>
   \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>u"
  by (fastforce simp: validU_def)

lemma bind_wpU[wp']:
  "(\<And>x.\<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>u) \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>B \<rbrace>u \<Longrightarrow> \<lbrace>A\<rbrace> f >>= g \<lbrace>C\<rbrace>u"
  by (rule hoare_seq_extU)

lemma get_wpU[wp']: "\<lbrace>\<lambda>s. P (fst s) s \<rbrace> get \<lbrace> P \<rbrace>u"
  by (clarsimp simp: get_def validU_def)

lemma put_wpU[wp']: "\<lbrace>\<lambda>s'. P () (s, snd s') \<rbrace> put s \<lbrace> P \<rbrace>u"
  by (clarsimp simp: put_def validU_def)

lemma fail_wpU[wp']: "\<lbrace>\<lambda>s. P () (fst s, False) \<rbrace> fail \<lbrace> P \<rbrace>u"
  by (simp add: fail_def validU_def)

lemma return_wpU[wp']: "\<lbrace>P x\<rbrace> return x \<lbrace>P\<rbrace>u"
  by (simp add: validU_def return_def)

lemma if_wpU[wp']:
  "\<lbrakk> Q \<Longrightarrow> \<lbrace>A\<rbrace> f \<lbrace>P\<rbrace>u; \<not>Q \<Longrightarrow> \<lbrace>B\<rbrace> g \<lbrace>P\<rbrace>u\<rbrakk> \<Longrightarrow>
  \<lbrace>\<lambda>s. (Q \<longrightarrow> A s) \<and> (\<not>Q \<longrightarrow> B s)\<rbrace> if Q then f else g \<lbrace>P\<rbrace>u"
  by auto

lemma assert_wpU[wp']:
  "\<lbrace>\<lambda>s. P () (fst s, Q \<and> snd s) \<rbrace> assert Q \<lbrace> P \<rbrace>u"
  unfolding assert_def by wp auto

lemma state_assert_wpU[wp']:
  "\<lbrace>\<lambda>s.  P () (fst s, Q (fst s) \<and> snd s) \<rbrace> state_assert Q \<lbrace> P \<rbrace>u"
  unfolding state_assert_def by wp

lemma modify_wpU[wp']:
  "\<lbrace>\<lambda>s. P ()  (f (fst s), snd s)\<rbrace> modify f \<lbrace>P\<rbrace>u"
  unfolding modify_def by wp

lemma gets_wpU[wp']: "\<lbrace>\<lambda>s.  P (f (fst s)) s \<rbrace> gets f \<lbrace> P \<rbrace>u"
  unfolding gets_def by wp

end


(*  Title:      HOL/Library/RBT_Mapping.thy
    Author:     Florian Haftmann and Ondrej Kuncar
*)

section \<open>Implementation of mappings with Red-Black Trees\<close>

(*<*)
theory RBT_Mapping
imports RBT Mapping
begin

subsection \<open>Implementation of mappings\<close>

context includes rbt.lifting begin
lift_definition Mapping :: "('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) mapping" is RBT.lookup .
end

code_datatype Mapping

context includes rbt.lifting begin

lemma lookup_Mapping [simp, code]:
  "Mapping.lookup (Mapping t) = RBT.lookup t"
   by (transfer fixing: t) rule

lemma empty_Mapping [code]: "Mapping.empty = Mapping RBT.empty"
proof -
  note RBT.empty.transfer[transfer_rule del]
  show ?thesis by transfer simp
qed

lemma is_empty_Mapping [code]:
  "Mapping.is_empty (Mapping t) \<longleftrightarrow> RBT.is_empty t"
  unfolding is_empty_def by (transfer fixing: t) simp

lemma insert_Mapping [code]:
  "Mapping.update k v (Mapping t) = Mapping (RBT.insert k v t)"
  by (transfer fixing: t) simp

lemma delete_Mapping [code]:
  "Mapping.delete k (Mapping t) = Mapping (RBT.delete k t)"
  by (transfer fixing: t) simp

lemma map_entry_Mapping [code]:
  "Mapping.map_entry k f (Mapping t) = Mapping (RBT.map_entry k f t)"
  apply (transfer fixing: t)
  apply (case_tac "RBT.lookup t k")
   apply auto
  done

lemma keys_Mapping [code]:
  "Mapping.keys (Mapping t) = set (RBT.keys t)"
by (transfer fixing: t) (simp add: lookup_keys)

lemma ordered_keys_Mapping [code]:
  "Mapping.ordered_keys (Mapping t) = RBT.keys t"
unfolding ordered_keys_def
by (transfer fixing: t) (auto simp add: lookup_keys intro: sorted_distinct_set_unique)

lemma Map_graph_lookup: "Map.graph (RBT.lookup t) = set (RBT.entries t)"
  by (metis RBT.distinct_entries RBT.map_of_entries graph_map_of_if_distinct_dom)

lemma entries_Mapping [code]: "Mapping.entries (Mapping t) = set (RBT.entries t)"
  by (transfer fixing: t) (fact Map_graph_lookup)

lemma ordered_entries_Mapping [code]: "Mapping.ordered_entries (Mapping t) = RBT.entries t"
proof -
  note folding_Map_graph.idem_if_sorted_distinct[
      where ?m="RBT.lookup t", OF _ _ folding_Map_graph.distinct_if_distinct_map]
  then show ?thesis
    unfolding ordered_entries_def
    by (transfer fixing: t) (auto simp: Map_graph_lookup distinct_entries sorted_entries)
qed

lemma fold_Mapping [code]: "Mapping.fold f (Mapping t) a = RBT.fold f t a"
  by (simp add: Mapping.fold_def fold_fold ordered_entries_Mapping)

lemma Mapping_size_card_keys: (*FIXME*)
  "Mapping.size m = card (Mapping.keys m)"
unfolding size_def by transfer simp

lemma size_Mapping [code]:
  "Mapping.size (Mapping t) = length (RBT.keys t)"
unfolding size_def
by (transfer fixing: t) (simp add: lookup_keys distinct_card)

context
  notes RBT.bulkload.transfer[transfer_rule del]
begin

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

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

end

lemma map_values_Mapping [code]:
  "Mapping.map_values f (Mapping t) = Mapping (RBT.map f t)"
  by (transfer fixing: t) (auto simp: fun_eq_iff)

lemma filter_Mapping [code]:
  "Mapping.filter P (Mapping t) = Mapping (RBT.filter P t)"
  by (transfer' fixing: P t) (simp add: RBT.lookup_filter fun_eq_iff)

lemma combine_with_key_Mapping [code]:
  "Mapping.combine_with_key f (Mapping t1) (Mapping t2) =
     Mapping (RBT.combine_with_key f t1 t2)"
  by (transfer fixing: f t1 t2) (simp_all add: fun_eq_iff)

lemma combine_Mapping [code]:
  "Mapping.combine f (Mapping t1) (Mapping t2) =
     Mapping (RBT.combine f t1 t2)"
  by (transfer fixing: f t1 t2) (simp_all add: fun_eq_iff)

lemma equal_Mapping [code]:
  "HOL.equal (Mapping t1) (Mapping t2) \<longleftrightarrow> RBT.entries t1 = RBT.entries t2"
  by (transfer fixing: t1 t2) (simp add: RBT.entries_lookup)

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

end

(*>*)

text \<open>
  This theory defines abstract red-black trees as an efficient
  representation of finite maps, backed by the implementation
  in \<^theory>\<open>HOL-Library.RBT_Impl\<close>.
\<close>

subsection \<open>Data type and invariant\<close>

text \<open>
  The type \<^typ>\<open>('k, 'v) RBT_Impl.rbt\<close> denotes red-black trees with
  keys of type \<^typ>\<open>'k\<close> and values of type \<^typ>\<open>'v\<close>. To function
  properly, the key type musorted belong to the \<open>linorder\<close>
  class.

  A value \<^term>\<open>t\<close> of this type is a valid red-black tree if it
  satisfies the invariant \<open>is_rbt t\<close>.  The abstract type \<^typ>\<open>('k, 'v) rbt\<close> always obeys this invariant, and for this reason you
  should only use this in our application.  Going back to \<^typ>\<open>('k,
  'v) RBT_Impl.rbt\<close> may be necessary in proofs if not yet proven
  properties about the operations must be established.

  The interpretation function \<^const>\<open>RBT.lookup\<close> returns the partial
  map represented by a red-black tree:
  @{term_type[display] "RBT.lookup"}

  This function should be used for reasoning about the semantics of the RBT
  operations. Furthermore, it implements the lookup functionality for
  the data structure: It is executable and the lookup is performed in
  $O(\log n)$.
\<close>

subsection \<open>Operations\<close>

text \<open>
  Currently, the following operations are supported:

  @{term_type [display] "RBT.empty"}
  Returns the empty tree. $O(1)$

  @{term_type [display] "RBT.insert"}
  Updates the map at a given position. $O(\log n)$

  @{term_type [display] "RBT.delete"}
  Deletes a map entry at a given position. $O(\log n)$

  @{term_type [display] "RBT.entries"}
  Return a corresponding key-value list for a tree.

  @{term_type [display] "RBT.bulkload"}
  Builds a tree from a key-value list.

  @{term_type [display] "RBT.map_entry"}
  Maps a single entry in a tree.

  @{term_type [display] "RBT.map"}
  Maps all values in a tree. $O(n)$

  @{term_type [display] "RBT.fold"}
  Folds over all entries in a tree. $O(n)$
\<close>

subsection \<open>Invariant preservation\<close>

text \<open>
  \noindent
  @{thm Empty_is_rbt}\hfill(\<open>Empty_is_rbt\<close>)

  \noindent
  @{thm rbt_insert_is_rbt}\hfill(\<open>rbt_insert_is_rbt\<close>)

  \noindent
  @{thm rbt_delete_is_rbt}\hfill(\<open>delete_is_rbt\<close>)

  \noindent
  @{thm rbt_bulkload_is_rbt}\hfill(\<open>bulkload_is_rbt\<close>)

  \noindent
  @{thm rbt_map_entry_is_rbt}\hfill(\<open>map_entry_is_rbt\<close>)

  \noindent
  @{thm map_is_rbt}\hfill(\<open>map_is_rbt\<close>)

  \noindent
  @{thm rbt_union_is_rbt}\hfill(\<open>union_is_rbt\<close>)
\<close>

subsection \<open>Map Semantics\<close>

text \<open>
  \noindent
  \underline{\<open>lookup_empty\<close>}
  @{thm [display] lookup_empty}
  \vspace{1ex}

  \noindent
  \underline{\<open>lookup_insert\<close>}
  @{thm [display] lookup_insert}
  \vspace{1ex}

  \noindent
  \underline{\<open>lookup_delete\<close>}
  @{thm [display] lookup_delete}
  \vspace{1ex}

  \noindent
  \underline{\<open>lookup_bulkload\<close>}
  @{thm [display] lookup_bulkload}
  \vspace{1ex}

  \noindent
  \underline{\<open>lookup_map\<close>}
  @{thm [display] lookup_map}
  \vspace{1ex}
\<close>

end


theory Chapter13_5
imports Main "HOL-Library.Lattice_Syntax"
begin

text \<open>
0:
  A1: None
  A2: None
  A3: None
  A4: None
  A5: None

1:
  A1: Odd

2:
  A2: Odd

3:
  A3: Odd

4:
  A4: Even

5:
  A2: Either

6:
  A3: Either
  A5: Either

7:
  A4: Either

8:
  No change
\<close>

text\<open>
\setcounter{exercise}{10}

\begin{exercise}
Take the Isabelle theories that define commands, big-step semantics,
annotated commands and the collecting semantics and extend them with a
nondeterministic choice construct. Start with Exercise~\ref{exe:IMP:OR}
and extend type @{text com}, then extend type @{text acom} with a
corresponding construct:
\begin{alltt}
  Or "'a acom" "'a acom" 'a     ("_ OR// _//{_}"  [60, 61, 0] 60)
\end{alltt}
Finally extend function @{text Step}. Update proofs as well.
Hint: think of @{text OR} as a nondeterministic conditional without a test.
\end{exercise}

\exercise
Prove the following lemmas in a detailed and readable style:
\<close>

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"  and  "f q \<le> q"  and  "x0 \<le> q"
shows "(f ^^ i) x0 \<le> q"
proof (induction i)
  case 0
  then show ?case by (auto simp add: assms(3))
next
  case (Suc i)
  have "(f ^^ Suc i) x0 = f ((f ^^ i) x0)" by auto
  also have "\<dots> \<le> f q" by (auto intro!: assms(1) simp add: Suc)
  also from assms(2) have "\<dots> \<le> q" .
  finally show ?case .
qed

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y" and "x0 \<le> f x0"
shows "(f ^^ i) x0 \<le> (f ^^ (i+1)) x0"
proof (induction i)
case 0
  then show ?case by (auto simp add: assms(2))
next
  case (Suc i)
  have "(f ^^ Suc i) x0 = f ((f ^^ i) x0)" by auto
  also have "\<dots> \<le> f ((f ^^ (i + 1)) x0)" by (intro assms(1), rule Suc)
  also have "\<dots> = (f ^^ (Suc i + 1)) x0" by auto
  finally show ?case .
qed

text\<open>
\endexercise

\exercise% needs Lattice_Syntax
Let @{typ 'a} be a complete lattice and
let @{text "f :: 'a \<Rightarrow> 'a"} be a monotone function.
Give a readable proof that if @{text P} is a set of pre-fixpoints of @{text f}
then @{text"\<Sqinter>P"} is also a pre-fixpoint of @{text f}:
\<close>

lemma fixes P :: "'a::complete_lattice set"
assumes "mono f" and "\<forall>p \<in> P. f p \<le> p"
shows "f(\<Sqinter> P) \<le> \<Sqinter> P" (is "f ?m \<le> ?m")
proof (intro Inf_greatest)
  fix p
  assume Hp: "p \<in> P"
  then have "?m \<le> p" by (rule Inf_lower)
  with assms(1) have "f ?m \<le> f p" unfolding mono_def by simp
  also from Hp assms(2) have "f p \<le> p" by simp
  finally show "f ?m \<le> p" .
qed

text\<open>
Sledgehammer should give you a proof you can start from.
\endexercise
\<close>

end


(*
  Author:     Jeremy Dawson and Gerwin Klein, NICTA

  Consequences of type definition theorems, and of extended type definition.
*)

section {* Type Definition Theorems *}

theory Misc_Typedef
imports Main
begin

section "More lemmas about normal type definitions"

lemma
  tdD1: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Rep x \<in> A" and
  tdD2: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Abs (Rep x) = x" and
  tdD3: "type_definition Rep Abs A \<Longrightarrow> \<forall>y. y \<in> A \<longrightarrow> Rep (Abs y) = y"
  by (auto simp: type_definition_def)

lemma td_nat_int:
  "type_definition int nat (Collect (op <= 0))"
  unfolding type_definition_def by auto

context type_definition
begin

declare Rep [iff] Rep_inverse [simp] Rep_inject [simp]

lemma Abs_eqD: "Abs x = Abs y ==> x \<in> A ==> y \<in> A ==> x = y"
  by (simp add: Abs_inject)

lemma Abs_inverse':
  "r : A ==> Abs r = a ==> Rep a = r"
  by (safe elim!: Abs_inverse)

lemma Rep_comp_inverse:
  "Rep o f = g ==> Abs o g = f"
  using Rep_inverse by auto

lemma Rep_eqD [elim!]: "Rep x = Rep y ==> x = y"
  by simp

lemma Rep_inverse': "Rep a = r ==> Abs r = a"
  by (safe intro!: Rep_inverse)

lemma comp_Abs_inverse:
  "f o Abs = g ==> g o Rep = f"
  using Rep_inverse by auto

lemma set_Rep:
  "A = range Rep"
proof (rule set_eqI)
  fix x
  show "(x \<in> A) = (x \<in> range Rep)"
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma set_Rep_Abs: "A = range (Rep o Abs)"
proof (rule set_eqI)
  fix x
  show "(x \<in> A) = (x \<in> range (Rep o Abs))"
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma Abs_inj_on: "inj_on Abs A"
  unfolding inj_on_def
  by (auto dest: Abs_inject [THEN iffD1])

lemma image: "Abs ` A = UNIV"
  by (auto intro!: image_eqI)

lemmas td_thm = type_definition_axioms

lemma fns1:
  "Rep o fa = fr o Rep | fa o Abs = Abs o fr ==> Abs o fr o Rep = fa"
  by (auto dest: Rep_comp_inverse elim: comp_Abs_inverse simp: o_assoc)

lemmas fns1a = disjI1 [THEN fns1]
lemmas fns1b = disjI2 [THEN fns1]

lemma fns4:
  "Rep o fa o Abs = fr ==>
   Rep o fa = fr o Rep & fa o Abs = Abs o fr"
  by auto

end

interpretation nat_int: type_definition int nat "Collect (op <= 0)"
  by (rule td_nat_int)

declare
  nat_int.Rep_cases [cases del]
  nat_int.Abs_cases [cases del]
  nat_int.Rep_induct [induct del]
  nat_int.Abs_induct [induct del]

subsection "Extended form of type definition predicate"

lemma td_conds:
  "norm o norm = norm ==> (fr o norm = norm o fr) =
    (norm o fr o norm = fr o norm & norm o fr o norm = norm o fr)"
  apply safe
    apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma fn_comm_power:
  "fa o tr = tr o fr ==> fa ^^ n o tr = tr o fr ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (auto dest: fun_cong)
  done

lemmas fn_comm_power' =
  ext [THEN fn_comm_power, THEN fun_cong, unfolded o_def]

locale td_ext = type_definition +
  fixes norm
  assumes eq_norm: "\<And>x. Rep (Abs x) = norm x"
begin

lemma Abs_norm [simp]:
  "Abs (norm x) = Abs x"
  using eq_norm [of x] by (auto elim: Rep_inverse')

lemma td_th:
  "g o Abs = f ==> f (Rep x) = g x"
  by (drule comp_Abs_inverse [symmetric]) simp

lemma eq_norm': "Rep o Abs = norm"
  by (auto simp: eq_norm)

lemma norm_Rep [simp]: "norm (Rep x) = Rep x"
  by (auto simp: eq_norm' intro: td_th)

lemmas td = td_thm

lemma set_iff_norm: "w : A <-> w = norm w"
  by (auto simp: set_Rep_Abs eq_norm' eq_norm [symmetric])

lemma inverse_norm:
  "(Abs n = w) = (Rep w = norm n)"
  apply (rule iffI)
   apply (clarsimp simp add: eq_norm)
  apply (simp add: eq_norm' [symmetric])
  done

lemma norm_eq_iff:
  "(norm x = norm y) = (Abs x = Abs y)"
  by (simp add: eq_norm' [symmetric])

lemma norm_comps:
  "Abs o norm = Abs"
  "norm o Rep = Rep"
  "norm o norm = norm"
  by (auto simp: eq_norm' [symmetric] o_def)

lemmas norm_norm [simp] = norm_comps

lemma fns5:
  "Rep o fa o Abs = fr ==>
  fr o norm = fr & norm o fr = fr"
  by (fold eq_norm') auto

(* following give conditions for converses to td_fns1
  the condition (norm o fr o norm = fr o norm) says that
  fr takes normalised arguments to normalised results,
  (norm o fr o norm = norm o fr) says that fr
  takes norm-equivalent arguments to norm-equivalent results,
  (fr o norm = fr) says that fr
  takes norm-equivalent arguments to the same result, and
  (norm o fr = fr) says that fr takes any argument to a normalised result
  *)
lemma fns2:
  "Abs o fr o Rep = fa ==>
   (norm o fr o norm = fr o norm) = (Rep o fa = fr o Rep)"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: o_assoc)
  apply (rule ext)
  apply (drule_tac x="Rep x" in fun_cong)
  apply auto
  done

lemma fns3:
  "Abs o fr o Rep = fa ==>
   (norm o fr o norm = norm o fr) = (fa o Abs = Abs o fr)"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: comp_assoc)
  apply (rule ext)
  apply (drule_tac f="?a o ?b" in fun_cong)
  apply simp
  done

lemma fns:
  "fr o norm = norm o fr ==>
    (fa o Abs = Abs o fr) = (Rep o fa = fr o Rep)"
  apply safe
   apply (frule fns1b)
   prefer 2
   apply (frule fns1a)
   apply (rule fns3 [THEN iffD1])
     prefer 3
     apply (rule fns2 [THEN iffD1])
       apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma range_norm:
  "range (Rep o Abs) = A"
  by (simp add: set_Rep_Abs)

end

lemmas td_ext_def' =
  td_ext_def [unfolded type_definition_def td_ext_axioms_def]

end


theory Concrete

imports
  Main
  "Category2/Category"
  "Category2/Functors"
  "Category2/SetCat"
  "ProductCategory"

begin

locale FaithfulFunctor = Functor +
  fixes C :: "('o, 'm, 'a) Category_scheme"
  assumes "CatDom F = C"
  and inj: "\<And>c c' f1 f2.
            \<lbrakk> c \<in> Obj C ; c' \<in> Obj C ;
              f1 \<in> Mor C ; f2 \<in> Mor C ;
              Dom C f1 = c ; Dom C f2 = c ;
              Cod C f1 = c' ; Cod C f2 = c' ;
              F ## f1 = F ## f2
            \<rbrakk> \<Longrightarrow>
            f1 = f2"

record ('o, 'm, 'a, 'b) ConcreteCategory =
  Cat :: "('o, 'm, 'a) Category_scheme"
  FF :: "('o, ZF, 'm, ZF, 'a, ZF, 'b) Functor_scheme"
  (* Embeds category into Set: not sure for the 3rd ZF type instance *)

definition DiagonalFunctor'' where
  "DiagonalFunctor'' C \<equiv> \<lparr>
      CatDom = C,
      CatCod = C,
      MapM = \<lambda>m. m
  \<rparr>"

lemma IdentityFunctorFaithful:
  fixes C
  assumes "Category C"
  shows "FaithfulFunctor (FId C) C"
proof -
  fix f1 f2 c c'
  have dom: "CatDom (FId' C) = C"
    by (simp add: IdentityFunctor'_def)
  have ftor: "Functor (FId C)" using assms by (rule Functors.IdFtorFtor)
  have inj: "\<lbrakk> c \<in> Obj C ; c' \<in> Obj C ;
            f1 \<in> Mor C ; f2 \<in> Mor C ;
            Dom C f1 = c ; Dom C f2 = c ;
            Cod C f1 = c' ; Cod C f2 = c' ;
            (FId C) ## f1 = (FId C) ## f2
         \<rbrakk> \<Longrightarrow>
         f1 = f2"
    proof -

    have left: "f1 \<in> Mor C \<Longrightarrow> (FId C) ## f1 = f1" using assms
      apply (simp add: IdentityFunctor_def MakeFtor_def, auto)
      apply (simp add: IdentityFunctor'_def)
      by (rule ccontr, insert assms(1), simp add: IdentityFunctor'_def)

    have right: "f2 \<in> Mor C \<Longrightarrow> (FId C) ## f2 = f2" using assms
      apply (simp add: IdentityFunctor_def MakeFtor_def, auto)
      apply (simp add: IdentityFunctor'_def)
      by (rule ccontr, insert assms(1), simp add: IdentityFunctor'_def)

    assume "(FId C) ## f1 = (FId C) ## f2" and "f1 \<in> Mor C" and "f2 \<in> Mor C"
    then show ?thesis using left right
    by auto
    qed

  show ?thesis using local.ftor local.dom local.inj
oops

(* Comment reconstruire la preuve après l'avoir découpée ? *)
(*
lemma IdentityFunctorFaithful:
  fixes C
  assumes "Category C"
  shows "FaithfulFunctor (FId C) C"
proof -
  fix f1 f2 c c'
  have "Functor (FId C)" using assms by (rule Functors.IdFtorFtor)
  have "\<lbrakk> c \<in> Obj C ; c' \<in> Obj C ;
            f1 \<in> Mor C ; f2 \<in> Mor C ;
            Dom C f1 = c ; Dom C f2 = c ;
            Cod C f1 = c' ; Cod C f2 = c' ;
            (FId C) ## f1 = (FId C) ## f2
         \<rbrakk> \<Longrightarrow>
         f1 = f2"

  proof -

    have left: "f1 \<in> Mor C \<Longrightarrow> (FId C) ## f1 = f1" using assms
        proof (simp add: IdentityFunctor_def MakeFtor_def, auto)

          have *: "f1 \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> Category C \<Longrightarrow> f1 \<in> mor\<^bsub>CatDom FId' C\<^esub> \<Longrightarrow> FId' C ## f1 = f1"
            by (simp add: IdentityFunctor'_def)

        moreover (* next ? *)

          have **: "f1 \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> Category C \<Longrightarrow> f1 \<notin> mor\<^bsub>CatDom FId' C\<^esub> \<Longrightarrow> undefined = f1"
            by (rule ccontr, insert assms(1), simp add: IdentityFunctor'_def)

        ultimately have ?thesis
oops
*)

end


theory Prelude_ExamplePrograms
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"ga_selector_pre\", \"ga_injective_suc\", \"ga_disjoint_0_suc\",
     \"ga_selector_undef_pre_0\", \"X1_def_Nat\", \"X2_def_Nat\",
     \"X3_def_Nat\", \"X4_def_Nat\", \"X5_def_Nat\", \"X6_def_Nat\",
     \"X7_def_Nat\", \"X8_def_Nat\", \"X9_def_Nat\", \"decimal_def\",
     \"ga_comm___XPlus__\", \"ga_assoc___XPlus__\",
     \"ga_right_unit___XPlus__\", \"ga_left_unit___XPlus__\",
     \"ga_left_comm___XPlus__\", \"ga_comm___Xx__\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"ga_left_comm___Xx__\", \"ga_comm_min\",
     \"ga_assoc_min\", \"ga_left_comm_min\", \"ga_comm_max\",
     \"ga_assoc_max\", \"ga_right_unit_max\", \"ga_left_unit_max\",
     \"ga_left_comm_max\", \"leq_def1_Nat\", \"leq_def2_Nat\",
     \"leq_def3_Nat\", \"geq_def_Nat\", \"less_def_Nat\",
     \"greater_def_Nat\", \"even_0_Nat\", \"even_suc_Nat\",
     \"odd_def_Nat\", \"factorial_0\", \"factorial_suc\", \"add_0_Nat\",
     \"add_suc_Nat\", \"mult_0_Nat\", \"mult_suc_Nat\", \"power_0_Nat\",
     \"power_suc_Nat\", \"min_def_Nat\", \"max_def_Nat\",
     \"subTotal_def1_Nat\", \"subTotal_def2_Nat\", \"sub_dom_Nat\",
     \"sub_def_Nat\", \"divide_dom_Nat\", \"divide_0_Nat\",
     \"divide_Pos_Nat\", \"div_dom_Nat\", \"div_Nat\", \"mod_dom_Nat\",
     \"mod_Nat\", \"distr1_Nat\", \"distr2_Nat\", \"min_0\",
     \"div_mod_Nat\", \"power_Nat\", \"Comp1\", \"IdDef\", \"FlipDef\",
     \"FstDef\", \"SndDef\", \"CurryDef\", \"UncurryDef\", \"NotFalse\",
     \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\", \"OrDef\",
     \"OtherwiseDef\", \"AndPrefixDef\", \"OrPrefixDef\", \"NotFalse1\",
     \"NotTrue1\", \"notNot1\", \"notNot2\", \"EqualTDef\",
     \"EqualSymDef\", \"EqualReflex\", \"EqualTransT\", \"DiffDef\",
     \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\",
     \"TE3\", \"TE4\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\", \"IBE5\",
     \"IBE6\", \"IBE7\", \"IBE8\", \"IUE1\", \"IUE2\", \"IOE01\",
     \"IOE02\", \"IOE03\", \"IOE04\", \"IOE05\", \"IOE06\", \"IOE07\",
     \"IOE08\", \"IOE09\", \"LeIrreflexivity\", \"LeTAsymmetry\",
     \"LeTTransitive\", \"LeTTotal\", \"GeDef\", \"GeIrreflexivity\",
     \"GeTAsymmetry\", \"GeTTransitive\", \"GeTTotal\", \"LeqDef\",
     \"LeqReflexivity\", \"LeqTTransitive\", \"LeqTTotal\", \"GeqDef\",
     \"GeqReflexivity\", \"GeqTTransitive\", \"GeqTTotal\",
     \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\", \"EqFOrdRel\",
     \"EqTOrdTSubstE\", \"EqTOrdFSubstE\", \"EqTOrdTSubstD\",
     \"EqTOrdFSubstD\", \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\",
     \"LeqFGetFRel\", \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\",
     \"GeqFLeqFRel\", \"LeTGeFEqFRel\", \"LeFGeTEqTRel\",
     \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\", \"GeFLeTEqTRel\",
     \"GeqTLeFRel\", \"GeqFLeTRel\", \"LeqTLeTEqTRel\",
     \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\", \"GeqFGeFEqFRel\",
     \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\", \"CmpLTDef\",
     \"CmpEQDef\", \"CmpGTDef\", \"MaxYDef\", \"MaxXDef\", \"MinXDef\",
     \"MinYDef\", \"MaxSym\", \"MinSym\", \"TO1\", \"TO2\", \"TO3\",
     \"TO4\", \"TO5\", \"TO6\", \"TO7\", \"IOO13\", \"IOO14\",
     \"IOO15\", \"IOO16\", \"IOO17\", \"IOO18\", \"IOO19\", \"IOO20\",
     \"IOO21\", \"IOO22\", \"IOO23\", \"IOO24\", \"IOO25\", \"IOO26\",
     \"IOO27\", \"IOO28\", \"IOO29\", \"IOO30\", \"IOO31\", \"IOO32\",
     \"IOO33\", \"IBO5\", \"IBO6\", \"IBO7\", \"IBO8\", \"IBO9\",
     \"IBO10\", \"IBO11\", \"IBO12\", \"IUO01\", \"IUO02\", \"IUO03\",
     \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"LengthNil\",
     \"LengthCons\", \"NotDefHead\", \"HeadDef\", \"NotDefTail\",
     \"TailDef\", \"FoldrNil\", \"FoldrCons\", \"FoldlNil\",
     \"FoldlCons\", \"MapNil\", \"MapCons\", \"XPlusXPlusNil\",
     \"XPlusXPlusCons\", \"XPlusXPlusPrefixDef\", \"FilterNil\",
     \"FilterConsT\", \"FilterConsF\", \"ZipNil\", \"ZipConsNil\",
     \"ZipConsCons\", \"UnzipNil\", \"UnzipCons\", \"EqualListNilDef\",
     \"EqualListDef\", \"LeListNilFalse\", \"LeListDef\",
     \"FoldlDecomp\", \"MapDecomp\", \"MapFunctor\", \"FilterProm\",
     \"LengthNil1\", \"LengthEqualNil\", \"LengthEqualCons\",
     \"ZipSpec\", \"InitNil\", \"InitConsNil\", \"InitConsCons\",
     \"LastNil\", \"LastConsNil\", \"LastConsCons\", \"NullNil\",
     \"NullCons\", \"ReverseNil\", \"ReverseCons\", \"Foldr1Nil\",
     \"Foldr1ConsNil\", \"Foldr1ConsCons\", \"Foldl1Nil\",
     \"Foldl1ConsNil\", \"Foldl1ConsCons\", \"AndLDef\", \"OrLDef\",
     \"AnyDef\", \"AllDef\", \"ConcatDef\", \"ConcatMapDef\",
     \"MaximumDef\", \"MinimumDef\", \"TakeWhileNil\",
     \"TakeWhileConsT\", \"TakeWhileConsF\", \"DropWhileNil\",
     \"DropWhileConsT\", \"DropWhileConsF\", \"SpanNil\", \"SpanConsT\",
     \"SpanConsF\", \"SpanThm\", \"BreakDef\", \"BreakThm\",
     \"QsortNil\", \"QsortCons\", \"Program01\", \"Program02\"]"

typedecl Unit

datatype Nat = X0 ("0''") | X_suc "Nat" ("suc/'(_')" [3] 999)
datatype Bool = X_False ("False''") | X_True ("True''")
datatype Ordering = EQ | GT | LT
datatype 'a List = X_Cons 'a "'a List" | X_Nil ("Nil''")

consts
notH__X :: "Bool => Bool" ("(notH/ _)" [56] 56)
X1 :: "Nat" ("1''")
X2 :: "Nat" ("2''")
X3 :: "Nat" ("3''")
X4 :: "Nat" ("4''")
X5 :: "Nat" ("5''")
X6 :: "Nat" ("6''")
X7 :: "Nat" ("7''")
X8 :: "Nat" ("8''")
X9 :: "Nat" ("9''")
XLtXAmpXAmpXGt :: "Bool => Bool => Bool"
XLtXPlusXPlusXGt :: "'a List => 'a List => 'a List"
XLtXVBarXVBarXGt :: "Bool => Bool => Bool"
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XAtXAt__X :: "Nat => Nat => Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__X :: "Nat => Nat => Nat" ("(_/ ^''/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XExclam :: "Nat => Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__XX1 :: "Nat => Nat => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGtXEq__XX2 :: "'a => 'a => Bool" ("(_/ >=''''/ _)" [54,54] 52)
X__XGt__XX1 :: "Nat => Nat => bool" ("(_/ >''/ _)" [44,44] 42)
X__XGt__XX2 :: "'a => 'a => Bool" ("(_/ >''''/ _)" [54,54] 52)
X__XLtXEq__XX1 :: "Nat => Nat => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLtXEq__XX2 :: "'a => 'a => Bool" ("(_/ <=''''/ _)" [54,54] 52)
X__XLt__XX1 :: "Nat => Nat => bool" ("(_/ <''/ _)" [44,44] 42)
X__XLt__XX2 :: "'a => 'a => Bool" ("(_/ <''''/ _)" [54,54] 52)
X__XMinusXExclam__X :: "Nat => Nat => Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "Nat => Nat => Nat partial" ("(_/ -?/ _)" [54,54] 52)
X__XPlusXPlus__X :: "'a List => 'a List => 'a List" ("(_/ ++''/ _)" [54,54] 52)
X__XPlus__X :: "Nat => Nat => Nat" ("(_/ +''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XSlashXQuest__X :: "Nat => Nat => Nat partial" ("(_/ '/?/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X__Xx__X :: "Nat => Nat => Nat" ("(_/ *''/ _)" [54,54] 52)
X__div__X :: "Nat => Nat => Nat partial" ("(_/ div''/ _)" [54,54] 52)
X__mod__X :: "Nat => Nat => Nat partial" ("(_/ mod''/ _)" [54,54] 52)
X__o__X :: "('b => 'c) * ('a => 'b) => 'a => 'c"
X_all :: "('a => Bool) => 'a List => Bool"
X_andL :: "Bool List => Bool" ("andL/'(_')" [3] 999)
X_any :: "('a => Bool) => 'a List => Bool"
X_concat :: "'a List List => 'a List" ("concat''/'(_')" [3] 999)
X_curry :: "('a * 'b => 'c) => 'a => 'b => 'c"
X_dropWhile :: "('a => Bool) => 'a List => 'a List"
X_even :: "Nat => bool" ("even''/'(_')" [3] 999)
X_filter :: "('a => Bool) => 'a List => 'a List"
X_flip :: "('a => 'b => 'c) => 'b => 'a => 'c"
X_foldl :: "('a => 'b => 'a) => 'a => 'b List => 'a"
X_foldr :: "('a => 'b => 'b) => 'b => 'a List => 'b"
X_fst :: "'a => 'b => 'a" ("fst''/'(_,/ _')" [3,3] 999)
X_head :: "'a List => 'a partial" ("head/'(_')" [3] 999)
X_id :: "'a => 'a" ("id''/'(_')" [3] 999)
X_init :: "'a List => 'a List partial" ("init/'(_')" [3] 999)
X_last :: "'a List => 'a partial" ("last''/'(_')" [3] 999)
X_length :: "'a List => Nat" ("length''/'(_')" [3] 999)
X_map :: "('a => 'b) => 'a List => 'b List"
X_maxX1 :: "Nat => Nat => Nat" ("max''/'(_,/ _')" [3,3] 999)
X_maxX2 :: "'a => 'a => 'a"
X_maximum :: "'d List => 'd" ("maximum/'(_')" [3] 999)
X_minX1 :: "Nat => Nat => Nat" ("min''/'(_,/ _')" [3,3] 999)
X_minX2 :: "'a => 'a => 'a"
X_minimum :: "'d List => 'd" ("minimum/'(_')" [3] 999)
X_null :: "'a List => Bool" ("null''/'(_')" [3] 999)
X_odd :: "Nat => bool" ("odd''/'(_')" [3] 999)
X_orL :: "Bool List => Bool" ("orL/'(_')" [3] 999)
X_pre :: "Nat => Nat partial" ("pre/'(_')" [3] 999)
X_qsort :: "'a List => 'a List" ("qsort/'(_')" [3] 999)
X_reverse :: "'a List => 'a List" ("reverse/'(_')" [3] 999)
X_snd :: "'a => 'b => 'b" ("snd''/'(_,/ _')" [3,3] 999)
X_tail :: "'a List => 'a List partial" ("tail/'(_')" [3] 999)
X_takeWhile :: "('a => Bool) => 'a List => 'a List"
X_unzip :: "('a * 'b) List => 'a List * 'b List" ("unzip/'(_')" [3] 999)
X_zip :: "'a List => 'b List => ('a * 'b) List"
break :: "('a => Bool) => 'a List => 'a List * 'a List"
compare :: "'a => 'a => Ordering"
concatMap :: "('a => 'b List) => 'a List => 'b List"
foldl1 :: "('a => 'a => 'a) => 'a List => 'a partial"
foldr1 :: "('a => 'a => 'a) => 'a List => 'a partial"
otherwiseH :: "Bool"
span :: "('a => Bool) => 'a List => 'a List * 'a List"
uncurry :: "('a => 'b => 'c) => 'a * 'b => 'c"

axioms
ga_selector_pre [rule_format] :
"ALL XX1. pre(suc(XX1)) = makePartial XX1"

ga_injective_suc [rule_format] :
"ALL XX1. ALL Y1. suc(XX1) = suc(Y1) = (XX1 = Y1)"

ga_disjoint_0_suc [rule_format] : "ALL Y1. ~ 0' = suc(Y1)"

ga_selector_undef_pre_0 [rule_format] : "~ defOp (pre(0'))"

X1_def_Nat [rule_format] : "1' = suc(0')"

X2_def_Nat [rule_format] : "2' = suc(1')"

X3_def_Nat [rule_format] : "3' = suc(2')"

X4_def_Nat [rule_format] : "4' = suc(3')"

X5_def_Nat [rule_format] : "5' = suc(4')"

X6_def_Nat [rule_format] : "6' = suc(5')"

X7_def_Nat [rule_format] : "7' = suc(6')"

X8_def_Nat [rule_format] : "8' = suc(7')"

X9_def_Nat [rule_format] : "9' = suc(8')"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *' suc(9')) +' X_n"

ga_comm___XPlus__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___XPlus__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___XPlus__ [rule_format] : "ALL x. 0' +' x = x"

ga_left_comm___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. x +' (y +' z) = y +' (x +' z)"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x *' y = y *' x"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 1' *' x = x"

ga_left_comm___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. x *' (y *' z) = y *' (x *' z)"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_right_unit_max [rule_format] : "ALL x. max'(x, 0') = x"

ga_left_unit_max [rule_format] : "ALL x. max'(0', x) = x"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

leq_def1_Nat [rule_format] : "ALL X_n. 0' <=' X_n"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc(X_n) <=' 0'"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc(m) <=' suc(X_n)) = (m <=' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_0_Nat [rule_format] : "even'(0')"

even_suc_Nat [rule_format] : "ALL m. even'(suc(m)) = odd'(m)"

odd_def_Nat [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

factorial_0 [rule_format] : "0' !' = 1'"

factorial_suc [rule_format] :
"ALL X_n. suc(X_n) !' = suc(X_n) *' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0' +' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) +' m = suc(X_n +' m)"

mult_0_Nat [rule_format] : "ALL m. 0' *' m = 0'"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) *' m = (X_n *' m) +' m"

power_0_Nat [rule_format] : "ALL m. m ^' 0' = 1'"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^' suc(X_n) = m *' (m ^' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >' X_n --> X_n -! m = 0'"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <=' X_n --> makePartial (X_n -! m) = X_n -? m"

sub_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >=' X_n)"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = makePartial r = (m = r +' X_n)"

divide_dom_Nat [rule_format] :
"ALL m.
 ALL X_n.
 defOp (m /? X_n) = (~ X_n = 0' & m mod' X_n = makePartial 0')"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /? 0')"

divide_Pos_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r. X_n >' 0' --> m /? X_n = makePartial r = (m = r *' X_n)"

div_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = makePartial r =
 (EX s. m = (X_n *' r) +' s & s <' X_n)"

mod_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod' X_n = makePartial s =
 (EX r. m = (X_n *' r) +' s & s <' X_n)"

distr1_Nat [rule_format] :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"

distr2_Nat [rule_format] :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"

min_0 [rule_format] : "ALL m. min'(m, 0') = 0'"

div_mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 makePartial m =
 (let (Xb5, Xc0) =
      let (Xb4, Xc3) = m div' X_n
      in if Xb4 then makePartial (Xc3 *' X_n) else noneOp
  in if Xb5
        then let (Xb2, Xc1) = m mod' X_n
             in if Xb2 then makePartial (Xc0 +' Xc1) else noneOp
        else noneOp)"

power_Nat [rule_format] :
"ALL m. ALL r. ALL s. m ^' (r +' s) = (m ^' r) *' (m ^' s)"

Comp1 [rule_format] :
"ALL f. ALL g. ALL y. X__o__X (f, g) y = f (g y)"

IdDef [rule_format] : "ALL x. id'(x) = x"

FlipDef [rule_format] : "ALL f. ALL x. ALL y. X_flip f y x = f x y"

FstDef [rule_format] : "ALL x. ALL y. fst'(x, y) = x"

SndDef [rule_format] : "ALL x. ALL y. snd'(x, y) = y"

CurryDef [rule_format] :
"ALL g. ALL x. ALL y. X_curry g x y = g (x, y)"

UncurryDef [rule_format] :
"ALL f. ALL x. ALL y. uncurry f (x, y) = f x y"

NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

AndTrue [rule_format] : "ALL x. True' && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

AndPrefixDef [rule_format] :
"ALL x. ALL y. XLtXAmpXAmpXGt x y = x && y"

OrPrefixDef [rule_format] :
"ALL x. ALL y. XLtXVBarXVBarXGt x y = x || y"

NotFalse1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

notNot1 [rule_format] : "ALL x. (~ x = True') = (Not' x = True')"

notNot2 [rule_format] : "ALL x. (~ x = False') = (Not' x = False')"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y = True'"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x = True'"

EqualTransT [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y ==' z = True' --> x ==' z = True'"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] :
"ALL x. ALL y. x /= y = True' = (Not' (x ==' y) = True')"

DiffFDef [rule_format] :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"

TE1 [rule_format] : "ALL x. ALL y. x ==' y = False' --> ~ x = y"

TE2 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"

TE3 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"

TE4 [rule_format] :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"

IBE1 [rule_format] : "True' ==' True' = True'"

IBE2 [rule_format] : "False' ==' False' = True'"

IBE3 [rule_format] : "False' ==' True' = False'"

IBE4 [rule_format] : "True' ==' False' = False'"

IBE5 [rule_format] : "True' /= False' = True'"

IBE6 [rule_format] : "False' /= True' = True'"

IBE7 [rule_format] : "Not' (True' ==' False') = True'"

IBE8 [rule_format] : "Not' Not' (True' ==' False') = False'"

IUE1 [rule_format] : "() ==' () = True'"

IUE2 [rule_format] : "() /= () = False'"

IOE01 [rule_format] : "LT ==' LT = True'"

IOE02 [rule_format] : "EQ ==' EQ = True'"

IOE03 [rule_format] : "GT ==' GT = True'"

IOE04 [rule_format] : "LT ==' EQ = False'"

IOE05 [rule_format] : "LT ==' GT = False'"

IOE06 [rule_format] : "EQ ==' GT = False'"

IOE07 [rule_format] : "LT /= EQ = True'"

IOE08 [rule_format] : "LT /= GT = True'"

IOE09 [rule_format] : "EQ /= GT = True'"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <'' y = False'"

LeTAsymmetry [rule_format] :
"ALL x. ALL y. x <'' y = True' --> y <'' x = False'"

LeTTransitive [rule_format] :
"ALL x.
 ALL y.
 ALL z. x <'' y = True' & y <'' z = True' --> x <'' z = True'"

LeTTotal [rule_format] :
"ALL x.
 ALL y. (x <'' y = True' | y <'' x = True') | x ==' y = True'"

GeDef [rule_format] : "ALL x. ALL y. x >'' y = y <'' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x >'' y = False'"

GeTAsymmetry [rule_format] :
"ALL x. ALL y. x >'' y = True' --> y >'' x = False'"

GeTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x >'' y) && (y >'' z) = True' --> x >'' z = True'"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >'' y) || (y >'' x)) || (x ==' y) = True'"

LeqDef [rule_format] :
"ALL x. ALL y. x <='' y = (x <'' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <='' x = True'"

LeqTTransitive [rule_format] :
"ALL x.
 ALL y.
 ALL z. (x <='' y) && (y <='' z) = True' --> x <='' z = True'"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <='' y) && (y <='' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >='' y = (x >'' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >='' x = True'"

GeqTTransitive [rule_format] :
"ALL x.
 ALL y.
 ALL z. (x >='' y) && (y >='' z) = True' --> x >='' z = True'"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >='' y) && (y >='' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <'' y = False' & x >'' y = False')"

EqFSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <'' y = True' | x >'' y = True')"

EqTOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <='' y = True' & x >='' y = True')"

EqFOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <='' y = True' | x >='' y = True')"

EqTOrdTSubstE [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y <'' z = True' --> x <'' z = True'"

EqTOrdFSubstE [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y <'' z = False' --> x <'' z = False'"

EqTOrdTSubstD [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & z <'' y = True' --> z <'' x = True'"

EqTOrdFSubstD [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & z <'' y = False' --> z <'' x = False'"

LeTGeTRel [rule_format] :
"ALL x. ALL y. x <'' y = True' = (y >'' x = True')"

LeFGeFRel [rule_format] :
"ALL x. ALL y. x <'' y = False' = (y >'' x = False')"

LeqTGetTRel [rule_format] :
"ALL x. ALL y. x <='' y = True' = (y >='' x = True')"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. x <='' y = False' = (y >='' x = False')"

GeTLeTRel [rule_format] :
"ALL x. ALL y. x >'' y = True' = (y <'' x = True')"

GeFLeFRel [rule_format] :
"ALL x. ALL y. x >'' y = False' = (y <'' x = False')"

GeqTLeqTRel [rule_format] :
"ALL x. ALL y. x >='' y = True' = (y <='' x = True')"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. x >='' y = False' = (y <='' x = False')"

LeTGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <'' y = True' = (x >'' y = False' & x ==' y = False')"

LeFGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <'' y = False' = (x >'' y = True' | x ==' y = True')"

LeqTGeFRel [rule_format] :
"ALL x. ALL y. x <='' y = True' = (x >'' y = False')"

LeqFGeTRel [rule_format] :
"ALL x. ALL y. x <='' y = False' = (x >'' y = True')"

GeTLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >'' y = True' = (x <'' y = False' & x ==' y = False')"

GeFLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >'' y = False' = (x <'' y = True' | x ==' y = True')"

GeqTLeFRel [rule_format] :
"ALL x. ALL y. x >='' y = True' = (x <'' y = False')"

GeqFLeTRel [rule_format] :
"ALL x. ALL y. x >='' y = False' = (x <'' y = True')"

LeqTLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <='' y = True' = (x <'' y = True' | x ==' y = True')"

LeqFLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <='' y = False' = (x <'' y = False' & x ==' y = False')"

GeqTGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >='' y = True' = (x >'' y = True' | x ==' y = True')"

GeqFGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >='' y = False' = (x >'' y = False' & x ==' y = False')"

LeTGeqFRel [rule_format] :
"ALL x. ALL y. x <'' y = True' = (x >='' y = False')"

GeTLeqFRel [rule_format] :
"ALL x. ALL y. x >'' y = True' = (x <='' y = False')"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <'' y = (x <='' y) && (x /= y)"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' LT = x <'' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' GT = x >'' y"

MaxYDef [rule_format] :
"ALL x. ALL y. X_maxX2 x y ==' y = x <='' y"

MaxXDef [rule_format] :
"ALL x. ALL y. X_maxX2 x y ==' x = y <='' x"

MinXDef [rule_format] :
"ALL x. ALL y. X_minX2 x y ==' x = x <='' y"

MinYDef [rule_format] :
"ALL x. ALL y. X_minX2 x y ==' y = y <='' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_maxX2 x y ==' y = X_maxX2 y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_minX2 x y ==' y = X_minX2 y x ==' y"

TO1 [rule_format] :
"ALL x.
 ALL y. (x ==' y = True' | x <'' y = True') = (x <='' y = True')"

TO2 [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <'' y = False'"

TO3 [rule_format] :
"ALL x.
 ALL y. Not' Not' (x <'' y) = True' | Not' (x <'' y) = True'"

TO4 [rule_format] :
"ALL x. ALL y. x <'' y = True' --> Not' (x ==' y) = True'"

TO5 [rule_format] :
"ALL w.
 ALL x.
 ALL y.
 ALL z.
 (x <'' y = True' & y <'' z = True') & z <'' w = True' -->
 x <'' w = True'"

TO6 [rule_format] :
"ALL x. ALL z. z <'' x = True' --> Not' (x <'' z) = True'"

TO7 [rule_format] :
"ALL x. ALL y. x <'' y = True' = (y >'' x = True')"

IOO13 [rule_format] : "LT <'' EQ = True'"

IOO14 [rule_format] : "EQ <'' GT = True'"

IOO15 [rule_format] : "LT <'' GT = True'"

IOO16 [rule_format] : "LT <='' EQ = True'"

IOO17 [rule_format] : "EQ <='' GT = True'"

IOO18 [rule_format] : "LT <='' GT = True'"

IOO19 [rule_format] : "EQ >='' LT = True'"

IOO20 [rule_format] : "GT >='' EQ = True'"

IOO21 [rule_format] : "GT >='' LT = True'"

IOO22 [rule_format] : "EQ >'' LT = True'"

IOO23 [rule_format] : "GT >'' EQ = True'"

IOO24 [rule_format] : "GT >'' LT = True'"

IOO25 [rule_format] : "X_maxX2 LT EQ ==' EQ = True'"

IOO26 [rule_format] : "X_maxX2 EQ GT ==' GT = True'"

IOO27 [rule_format] : "X_maxX2 LT GT ==' GT = True'"

IOO28 [rule_format] : "X_minX2 LT EQ ==' LT = True'"

IOO29 [rule_format] : "X_minX2 EQ GT ==' EQ = True'"

IOO30 [rule_format] : "X_minX2 LT GT ==' LT = True'"

IOO31 [rule_format] : "compare LT LT ==' EQ = True'"

IOO32 [rule_format] : "compare EQ EQ ==' EQ = True'"

IOO33 [rule_format] : "compare GT GT ==' EQ = True'"

IBO5 [rule_format] : "False' <'' True' = True'"

IBO6 [rule_format] : "False' >='' True' = False'"

IBO7 [rule_format] : "True' >='' False' = True'"

IBO8 [rule_format] : "True' <'' False' = False'"

IBO9 [rule_format] : "X_maxX2 False' True' ==' True' = True'"

IBO10 [rule_format] : "X_minX2 False' True' ==' False' = True'"

IBO11 [rule_format] : "compare True' True' ==' EQ = True'"

IBO12 [rule_format] : "compare False' False' ==' EQ = True'"

IUO01 [rule_format] : "() <='' () = True'"

IUO02 [rule_format] : "() <'' () = False'"

IUO03 [rule_format] : "() >='' () = True'"

IUO04 [rule_format] : "() >'' () = False'"

IUO05 [rule_format] : "X_maxX2 () () ==' () = True'"

IUO06 [rule_format] : "X_minX2 () () ==' () = True'"

IUO07 [rule_format] : "compare () () ==' EQ = True'"

LengthNil [rule_format] : "length'(Nil') = 0'"

LengthCons [rule_format] :
"ALL x. ALL xs. length'(X_Cons x xs) = suc(length'(xs))"

NotDefHead [rule_format] : "~ defOp (head(Nil'))"

HeadDef [rule_format] :
"ALL x. ALL xs. head(X_Cons x xs) = makePartial x"

NotDefTail [rule_format] : "~ defOp (tail(Nil'))"

TailDef [rule_format] :
"ALL x. ALL xs. tail(X_Cons x xs) = makePartial xs"

FoldrNil [rule_format] : "ALL f. ALL s. X_foldr f s Nil' = s"

FoldrCons [rule_format] :
"ALL f.
 ALL s.
 ALL x. ALL xs. X_foldr f s (X_Cons x xs) = f x (X_foldr f s xs)"

FoldlNil [rule_format] : "ALL g. ALL t. X_foldl g t Nil' = t"

FoldlCons [rule_format] :
"ALL g.
 ALL t.
 ALL z. ALL zs. X_foldl g t (X_Cons z zs) = X_foldl g (g t z) zs"

MapNil [rule_format] : "ALL h. X_map h Nil' = Nil'"

MapCons [rule_format] :
"ALL h.
 ALL x. ALL xs. X_map h (X_Cons x xs) = X_Cons (h x) (X_map h xs)"

XPlusXPlusNil [rule_format] : "ALL l. Nil' ++' l = l"

XPlusXPlusCons [rule_format] :
"ALL l. ALL x. ALL xs. X_Cons x xs ++' l = X_Cons x (xs ++' l)"

XPlusXPlusPrefixDef [rule_format] :
"ALL xs. ALL ys. XLtXPlusXPlusXGt xs ys = xs ++' ys"

FilterNil [rule_format] : "ALL p. X_filter p Nil' = Nil'"

FilterConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' -->
 X_filter p (X_Cons x xs) = X_Cons x (X_filter p xs)"

FilterConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs. p x = False' --> X_filter p (X_Cons x xs) = X_filter p xs"

ZipNil [rule_format] : "ALL l. X_zip Nil' l = Nil'"

ZipConsNil [rule_format] :
"ALL l. ALL x. ALL xs. l = Nil' --> X_zip (X_Cons x xs) l = Nil'"

ZipConsCons [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 l = X_Cons y ys -->
 X_zip (X_Cons x xs) l = X_Cons (x, y) (X_zip xs ys)"

UnzipNil [rule_format] : "unzip(Nil') = (Nil', Nil')"

UnzipCons [rule_format] :
"ALL ps.
 ALL x.
 ALL z.
 unzip(X_Cons (x, z) ps) =
 (let (ys, zs) = unzip(ps) in (X_Cons x ys, X_Cons z zs))"

EqualListNilDef [rule_format] : "Nil' ==' Nil' = True'"

EqualListDef [rule_format] :
"ALL x.
 ALL xs.
 ALL y.
 ALL ys. X_Cons x xs ==' X_Cons y ys = (x ==' y) && (xs ==' ys)"

LeListNilFalse [rule_format] : "Nil' <'' Nil' = False'"

LeListDef [rule_format] :
"ALL w.
 ALL ws.
 ALL z.
 ALL zs. X_Cons z zs <'' X_Cons w ws = (z <'' w) && (zs <'' ws)"

FoldlDecomp [rule_format] :
"ALL e.
 ALL i.
 ALL ts.
 ALL ys. X_foldl i e (ys ++' ts) = X_foldl i (X_foldl i e ys) ts"

MapDecomp [rule_format] :
"ALL f.
 ALL xs. ALL zs. X_map f (xs ++' zs) = X_map f xs ++' X_map f zs"

MapFunctor [rule_format] :
"ALL f.
 ALL g. ALL xs. X_map (X__o__X (g, f)) xs = X_map g (X_map f xs)"

FilterProm [rule_format] :
"ALL f.
 ALL p.
 ALL xs.
 X_filter p (X_map f xs) = X_map f (X_filter (X__o__X (p, f)) xs)"

LengthNil1 [rule_format] : "ALL xs. length'(xs) = 0' = (xs = Nil')"

LengthEqualNil [rule_format] :
"ALL ys. length'(Nil') = length'(ys) --> ys = Nil'"

LengthEqualCons [rule_format] :
"ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 length'(X_Cons x xs) = length'(X_Cons y ys) -->
 length'(xs) = length'(ys)"

ZipSpec [rule_format] :
"ALL xs.
 ALL ys.
 length'(xs) = length'(ys) --> unzip(X_zip xs ys) = (xs, ys)"

InitNil [rule_format] : "~ defOp (init(Nil'))"

InitConsNil [rule_format] :
"ALL x. init(X_Cons x Nil') = makePartial Nil'"

InitConsCons [rule_format] :
"ALL x.
 ALL xs.
 init(X_Cons x xs) =
 (let (Xb1, Xc0) = init(xs)
  in if Xb1 then makePartial (X_Cons x Xc0) else noneOp)"

LastNil [rule_format] : "~ defOp (last'(Nil'))"

LastConsNil [rule_format] :
"ALL x. last'(X_Cons x Nil') = makePartial x"

LastConsCons [rule_format] :
"ALL x. ALL xs. last'(X_Cons x xs) = last'(xs)"

NullNil [rule_format] : "null'(Nil') = True'"

NullCons [rule_format] :
"ALL x. ALL xs. null'(X_Cons x xs) = False'"

ReverseNil [rule_format] : "reverse(Nil') = Nil'"

ReverseCons [rule_format] :
"ALL x.
 ALL xs. reverse(X_Cons x xs) = reverse(xs) ++' X_Cons x Nil'"

Foldr1Nil [rule_format] : "ALL f. ~ defOp (foldr1 f Nil')"

Foldr1ConsNil [rule_format] :
"ALL f. ALL x. foldr1 f (X_Cons x Nil') = makePartial x"

Foldr1ConsCons [rule_format] :
"ALL f.
 ALL x.
 ALL xs.
 foldr1 f (X_Cons x xs) =
 (let (Xb1, Xc0) = foldr1 f xs
  in if Xb1 then makePartial (f x Xc0) else noneOp)"

Foldl1Nil [rule_format] : "ALL f. ~ defOp (foldl1 f Nil')"

Foldl1ConsNil [rule_format] :
"ALL f. ALL x. foldl1 f (X_Cons x Nil') = makePartial x"

Foldl1ConsCons [rule_format] :
"ALL f.
 ALL x.
 ALL xs.
 foldl1 f (X_Cons x xs) =
 (let (Xb1, Xc0) = foldr1 f xs
  in if Xb1 then makePartial (f x Xc0) else noneOp)"

AndLDef [rule_format] :
"ALL bs. andL(bs) = X_foldr XLtXAmpXAmpXGt True' bs"

OrLDef [rule_format] :
"ALL bs. orL(bs) = X_foldr XLtXVBarXVBarXGt False' bs"

AnyDef [rule_format] :
"ALL p. ALL xs. X_any p xs = orL(X_map p xs)"

AllDef [rule_format] :
"ALL p. ALL xs. X_all p xs = andL(X_map p xs)"

ConcatDef [rule_format] :
"ALL xxs. concat'(xxs) = X_foldr XLtXPlusXPlusXGt Nil' xxs"

ConcatMapDef [rule_format] :
"ALL g. ALL xs. concatMap g xs = concat'(X_map g xs)"

MaximumDef [rule_format] :
"ALL ds. makePartial (maximum(ds)) = foldl1 X_maxX2 ds"

MinimumDef [rule_format] :
"ALL ds. makePartial (minimum(ds)) = foldl1 X_minX2 ds"

TakeWhileNil [rule_format] : "ALL p. X_takeWhile p Nil' = Nil'"

TakeWhileConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' -->
 X_takeWhile p (X_Cons x xs) = X_Cons x (X_takeWhile p xs)"

TakeWhileConsF [rule_format] :
"ALL p.
 ALL x. ALL xs. p x = False' --> X_takeWhile p (X_Cons x xs) = Nil'"

DropWhileNil [rule_format] : "ALL p. X_dropWhile p Nil' = Nil'"

DropWhileConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' --> X_dropWhile p (X_Cons x xs) = X_dropWhile p xs"

DropWhileConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs. p x = False' --> X_dropWhile p (X_Cons x xs) = X_Cons x xs"

SpanNil [rule_format] : "ALL p. span p Nil' = (Nil', Nil')"

SpanConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' -->
 span p (X_Cons x xs) =
 (let (ys, zs) = span p xs in (X_Cons x ys, zs))"

SpanConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = False' -->
 span p (X_Cons x xs) =
 (let (ys, zs) = span p xs in (Nil', X_Cons x xs))"

SpanThm [rule_format] :
"ALL p. ALL xs. span p xs = (X_takeWhile p xs, X_dropWhile p xs)"

BreakDef [rule_format] :
"ALL p.
 ALL xs. break p xs = (let q = X__o__X (notH__X, p) in span q xs)"

BreakThm [rule_format] :
"ALL p. ALL xs. break p xs = span (X__o__X (notH__X, p)) xs"

QsortNil [rule_format] : "qsort(Nil') = Nil'"

QsortCons [rule_format] :
"ALL x.
 ALL xs.
 qsort(X_Cons x xs) =
 (qsort(X_filter (% y. y <'' x) xs) ++' X_Cons x Nil') ++'
 qsort(X_filter (% y. y >='' x) xs)"

declare ga_selector_pre [simp]
declare ga_selector_undef_pre_0 [simp]
declare ga_comm___XPlus__ [simp]
declare ga_assoc___XPlus__ [simp]
declare ga_right_unit___XPlus__ [simp]
declare ga_left_unit___XPlus__ [simp]
declare ga_left_comm___XPlus__ [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare ga_left_comm___Xx__ [simp]
declare ga_comm_min [simp]
declare ga_assoc_min [simp]
declare ga_left_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_max [simp]
declare ga_right_unit_max [simp]
declare ga_left_unit_max [simp]
declare ga_left_comm_max [simp]
declare leq_def1_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare factorial_0 [simp]
declare add_0_Nat [simp]
declare mult_0_Nat [simp]
declare power_0_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare sub_dom_Nat [simp]
declare divide_0_Nat [simp]
declare min_0 [simp]
declare Comp1 [simp]
declare IdDef [simp]
declare FlipDef [simp]
declare FstDef [simp]
declare SndDef [simp]
declare CurryDef [simp]
declare UncurryDef [simp]
declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare LengthNil [simp]
declare LengthCons [simp]
declare NotDefHead [simp]
declare HeadDef [simp]
declare NotDefTail [simp]
declare TailDef [simp]
declare FoldrNil [simp]
declare FoldlNil [simp]
declare MapNil [simp]
declare XPlusXPlusNil [simp]
declare FilterNil [simp]
declare FilterConsF [simp]
declare ZipNil [simp]
declare EqualListNilDef [simp]
declare LeListNilFalse [simp]
declare InitNil [simp]
declare InitConsNil [simp]
declare LastNil [simp]
declare LastConsNil [simp]
declare LastConsCons [simp]
declare NullNil [simp]
declare NullCons [simp]
declare ReverseNil [simp]
declare Foldr1Nil [simp]
declare Foldr1ConsNil [simp]
declare Foldl1Nil [simp]
declare Foldl1ConsNil [simp]
declare TakeWhileNil [simp]
declare TakeWhileConsF [simp]
declare DropWhileNil [simp]
declare DropWhileConsT [simp]
declare DropWhileConsF [simp]
declare SpanNil [simp]
declare QsortNil [simp]

theorem Program01 :
"andL(X_Cons True' (X_Cons True' (X_Cons True' Nil'))) = True'"
apply(simp only: AndLDef)
apply(simp only: FoldrCons)
apply(simp only: FoldrNil)
apply(simp add: AndPrefixDef)
done

ML "Header.record \"Program01\""

theorem Program02 :
"qsort(X_Cons True' (X_Cons False' Nil')) =
 X_Cons False' (X_Cons True' Nil')"
apply(simp only: QsortCons)
apply(case_tac "(%y. y <'' True') False'")
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp only: XPlusXPlusNil)
apply(simp only: XPlusXPlusCons)
apply(simp only: XPlusXPlusNil)
apply(case_tac "(%y. y >='' True') False'")
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp add: LeFGeTEqTRel)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortCons)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp only: XPlusXPlusNil)
apply(simp only: XPlusXPlusCons)
apply(simp only: XPlusXPlusNil)
apply(simp only: IBO5)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortCons)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp only: XPlusXPlusNil)
apply(simp only: XPlusXPlusCons)
apply(simp only: XPlusXPlusNil)
apply(case_tac "(%y. y >='' True') False'")
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp only: XPlusXPlusCons)
apply(simp only: XPlusXPlusNil)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortCons)
apply(simp only: FilterNil FilterConsT FilterConsF)
apply(simp only: QsortNil)
apply(simp only: XPlusXPlusNil)
apply(simp only: XPlusXPlusCons)
apply(simp only: XPlusXPlusNil)
apply(simp add: LeFGeTEqTRel)
done

ML "Header.record \"Program02\""

end