(*  Title:      HOL/Unix/Nested_Environment.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Nested environments\<close>

theory Nested_Environment
imports Main
begin

text \<open>
  Consider a partial function @{term [source] "e :: 'a \<Rightarrow> 'b option"}; this may
  be understood as an \<^emph>\<open>environment\<close> mapping indexes \<^typ>\<open>'a\<close> to optional
  entry values \<^typ>\<open>'b\<close> (cf.\ the basic theory \<open>Map\<close> of Isabelle/HOL). This
  basic idea is easily generalized to that of a \<^emph>\<open>nested environment\<close>, where
  entries may be either basic values or again proper environments. Then each
  entry is accessed by a \<^emph>\<open>path\<close>, i.e.\ a list of indexes leading to its
  position within the structure.
\<close>

datatype (dead 'a, dead 'b, dead 'c) env =
    Val 'a
  | Env 'b  "'c \<Rightarrow> ('a, 'b, 'c) env option"

text \<open>
  \<^medskip>
  In the type \<^typ>\<open>('a, 'b, 'c) env\<close> the parameter \<^typ>\<open>'a\<close> refers to
  basic values (occurring in terminal positions), type \<^typ>\<open>'b\<close> to values
  associated with proper (inner) environments, and type \<^typ>\<open>'c\<close> with the
  index type for branching. Note that there is no restriction on any of these
  types. In particular, arbitrary branching may yield rather large
  (transfinite) tree structures.
\<close>

subsection \<open>The lookup operation\<close>

text \<open>
  Lookup in nested environments works by following a given path of index
  elements, leading to an optional result (a terminal value or nested
  environment). A \<^emph>\<open>defined position\<close> within a nested environment is one where
  \<^term>\<open>lookup\<close> at its path does not yield \<^term>\<open>None\<close>.
\<close>

primrec lookup :: "('a, 'b, 'c) env \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
  and lookup_option :: "('a, 'b, 'c) env option \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
where
    "lookup (Val a) xs = (if xs = [] then Some (Val a) else None)"
  | "lookup (Env b es) xs =
      (case xs of
        [] \<Rightarrow> Some (Env b es)
      | y # ys \<Rightarrow> lookup_option (es y) ys)"
  | "lookup_option None xs = None"
  | "lookup_option (Some e) xs = lookup e xs"

hide_const lookup_option

text \<open>
  \<^medskip>
  The characteristic cases of \<^term>\<open>lookup\<close> are expressed by the following
  equalities.
\<close>

theorem lookup_nil: "lookup e [] = Some e"
  by (cases e) simp_all

theorem lookup_val_cons: "lookup (Val a) (x # xs) = None"
  by simp

theorem lookup_env_cons:
  "lookup (Env b es) (x # xs) =
    (case es x of
      None \<Rightarrow> None
    | Some e \<Rightarrow> lookup e xs)"
  by (cases "es x") simp_all

lemmas lookup.simps [simp del] lookup_option.simps [simp del]
  and lookup_simps [simp] = lookup_nil lookup_val_cons lookup_env_cons

theorem lookup_eq:
  "lookup env xs =
    (case xs of
      [] \<Rightarrow> Some env
    | x # xs \<Rightarrow>
      (case env of
        Val a \<Rightarrow> None
      | Env b es \<Rightarrow>
          (case es x of
            None \<Rightarrow> None
          | Some e \<Rightarrow> lookup e xs)))"
  by (simp split: list.split env.split)

text \<open>
  \<^medskip>
  Displaced \<^term>\<open>lookup\<close> operations, relative to a certain base path prefix,
  may be reduced as follows. There are two cases, depending whether the
  environment actually extends far enough to follow the base path.
\<close>

theorem lookup_append_none:
  assumes "lookup env xs = None"
  shows "lookup env (xs @ ys) = None"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with Env show ?thesis by simp
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases "lookup e xs")
        case None
        then have "lookup e (xs @ ys) = None" by (rule Cons.hyps)
        with Env Some show ?thesis by simp
      next
        case Some
        with Env es have False using Cons.prems by simp
        then show ?thesis ..
      qed
    qed
  qed
qed

theorem lookup_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup env (xs @ ys) = lookup e ys"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show "lookup env ([] @ ys) = lookup e ys" by simp
next
  case (Cons x xs)
  note asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup env ((x # xs) @ ys) = lookup e ys"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases "lookup e' xs")
        case None
        with asm Env es have False by simp
        then show ?thesis ..
      next
        case Some
        with asm Env es have "lookup e' xs = Some e"
          by simp
        then have "lookup e' (xs @ ys) = lookup e ys" by (rule Cons.hyps)
        with Env es show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  Successful \<^term>\<open>lookup\<close> deeper down an environment structure means we are
  able to peek further up as well. Note that this is basically just the
  contrapositive statement of @{thm [source] lookup_append_none} above.
\<close>

theorem lookup_some_append:
  assumes "lookup env (xs @ ys) = Some e"
  shows "\<exists>e. lookup env xs = Some e"
proof -
  from assms have "lookup env (xs @ ys) \<noteq> None" by simp
  then have "lookup env xs \<noteq> None"
    by (rule contrapos_nn) (simp only: lookup_append_none)
  then show ?thesis by (simp)
qed

text \<open>
  The subsequent statement describes in more detail how a successful \<^term>\<open>lookup\<close> with a non-empty path results in a certain situation at any upper
  position.
\<close>

theorem lookup_some_upper:
  assumes "lookup env (xs @ y # ys) = Some e"
  shows "\<exists>b' es' env'.
    lookup env xs = Some (Env b' es') \<and>
    es' y = Some env' \<and>
    lookup env' ys = Some e"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  from Nil.prems have "lookup env (y # ys) = Some e"
    by simp
  then obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' y = Some env'" and
      look': "lookup env' ys = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from env have "lookup env [] = Some (Env b' es')" by simp
  with es' look' show ?case by blast
next
  case (Cons x xs)
  from Cons.prems
  obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' x = Some env'" and
      look': "lookup env' (xs @ y # ys) = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from Cons.hyps [OF look'] obtain b'' es'' env'' where
      upper': "lookup env' xs = Some (Env b'' es'')" and
      es'': "es'' y = Some env''" and
      look'': "lookup env'' ys = Some e"
    by blast
  from env es' upper' have "lookup env (x # xs) = Some (Env b'' es'')"
    by simp
  with es'' look'' show ?case by blast
qed

subsection \<open>The update operation\<close>

text \<open>
  Update at a certain position in a nested environment may either delete an
  existing entry, or overwrite an existing one. Note that update at undefined
  positions is simple absorbed, i.e.\ the environment is left unchanged.
\<close>

primrec update :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env \<Rightarrow> ('a, 'b, 'c) env"
  and update_option :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env option \<Rightarrow> ('a, 'b, 'c) env option"
where
  "update xs opt (Val a) =
    (if xs = [] then (case opt of None \<Rightarrow> Val a | Some e \<Rightarrow> e)
     else Val a)"
| "update xs opt (Env b es) =
    (case xs of
      [] \<Rightarrow> (case opt of None \<Rightarrow> Env b es | Some e \<Rightarrow> e)
    | y # ys \<Rightarrow> Env b (es (y := update_option ys opt (es y))))"
| "update_option xs opt None =
    (if xs = [] then opt else None)"
| "update_option xs opt (Some e) =
    (if xs = [] then opt else Some (update xs opt e))"

hide_const update_option

text \<open>
  \<^medskip>
  The characteristic cases of \<^term>\<open>update\<close> are expressed by the following
  equalities.
\<close>

theorem update_nil_none: "update [] None env = env"
  by (cases env) simp_all

theorem update_nil_some: "update [] (Some e) env = e"
  by (cases env) simp_all

theorem update_cons_val: "update (x # xs) opt (Val a) = Val a"
  by simp

theorem update_cons_nil_env:
    "update [x] opt (Env b es) = Env b (es (x := opt))"
  by (cases "es x") simp_all

theorem update_cons_cons_env:
  "update (x # y # ys) opt (Env b es) =
    Env b (es (x :=
      (case es x of
        None \<Rightarrow> None
      | Some e \<Rightarrow> Some (update (y # ys) opt e))))"
  by (cases "es x") simp_all

lemmas update.simps [simp del] update_option.simps [simp del]
  and update_simps [simp] = update_nil_none update_nil_some
    update_cons_val update_cons_nil_env update_cons_cons_env

lemma update_eq:
  "update xs opt env =
    (case xs of
      [] \<Rightarrow>
        (case opt of
          None \<Rightarrow> env
        | Some e \<Rightarrow> e)
    | x # xs \<Rightarrow>
        (case env of
          Val a \<Rightarrow> Val a
        | Env b es \<Rightarrow>
            (case xs of
              [] \<Rightarrow> Env b (es (x := opt))
            | y # ys \<Rightarrow>
                Env b (es (x :=
                  (case es x of
                    None \<Rightarrow> None
                  | Some e \<Rightarrow> Some (update (y # ys) opt e)))))))"
  by (simp split: list.split env.split option.split)

text \<open>
  \<^medskip>
  The most basic correspondence of \<^term>\<open>lookup\<close> and \<^term>\<open>update\<close> states
  that after \<^term>\<open>update\<close> at a defined position, subsequent \<^term>\<open>lookup\<close>
  operations would yield the new value.
\<close>

theorem lookup_update_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update xs (Some env') env) xs = Some env'"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show ?case
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with Env show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update xs (Some env') e') xs = Some env'" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  The properties of displaced \<^term>\<open>update\<close> operations are analogous to those
  of \<^term>\<open>lookup\<close> above. There are two cases: below an undefined position
  \<^term>\<open>update\<close> is absorbed altogether, and below a defined positions \<^term>\<open>update\<close> affects subsequent \<^term>\<open>lookup\<close> operations in the obvious way.
\<close>

theorem update_append_none:
  assumes "lookup env xs = None"
  shows "update (xs @ y # ys) opt env = env"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = None\<close>
  show "update ((x # xs) @ y # ys) opt env = env"
  proof (cases env)
    case (Val a)
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      note es = \<open>es x = None\<close>
      show ?thesis
        by (cases xs) (simp_all add: es Env fun_upd_idem_iff)
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env Some have False by simp
        then show ?thesis ..
      next
        case (Cons x' xs')
        from asm Env es have "lookup e xs = None" by simp
        then have "update (xs @ y # ys) opt e = e" by (rule hyp)
        with Env es Cons show "update ((x # xs) @ y # ys) opt env = env"
          by (simp add: fun_upd_idem_iff)
      qed
    qed
  qed
qed

theorem update_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update (xs @ y # ys) opt env) xs = Some (update (y # ys) opt e)"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup (update ((x # xs) @ y # ys) opt env) (x # xs) =
      Some (update (y # ys) opt e)"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env es have "e = e'" by simp
        with Env es Nil show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update (xs @ y # ys) opt e') xs =
          Some (update (y # ys) opt e)" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  Apparently, \<^term>\<open>update\<close> does not affect the result of subsequent \<^term>\<open>lookup\<close> operations at independent positions, i.e.\ in case that the paths
  for \<^term>\<open>update\<close> and \<^term>\<open>lookup\<close> fork at a certain point.
\<close>

theorem lookup_update_other:
  assumes neq: "y \<noteq> (z::'c)"
  shows "lookup (update (xs @ z # zs) opt env) (xs @ y # ys) =
    lookup env (xs @ y # ys)"
proof (induct xs arbitrary: env)
  case Nil
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case Env
    show ?thesis
    proof (cases zs)
      case Nil
      with neq Env show ?thesis by simp
    next
      case Cons
      with neq Env show ?thesis by simp
    qed
  qed
next
  case (Cons x xs)
  note hyp = Cons.hyps
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env y es)
    show ?thesis
    proof (cases xs)
      case Nil
      show ?thesis
      proof (cases "es x")
        case None
        with Env Nil show ?thesis by simp
      next
        case Some
        with neq hyp and Env Nil show ?thesis by simp
      qed
    next
      case (Cons x' xs')
      show ?thesis
      proof (cases "es x")
        case None
        with Env Cons show ?thesis by simp
      next
        case Some
        with neq hyp and Env Cons show ?thesis by simp
      qed
    qed
  qed
qed

subsection \<open>Code generation\<close>

lemma equal_env_code [code]:
  fixes x y :: "'a::equal"
    and f g :: "'c::{equal, finite} \<Rightarrow> ('b::equal, 'a, 'c) env option"
  shows
    "HOL.equal (Env x f) (Env y g) \<longleftrightarrow>
      HOL.equal x y \<and> (\<forall>z \<in> UNIV.
        case f z of
          None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
        | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> HOL.equal a b))" (is ?env)
    and "HOL.equal (Val a) (Val b) \<longleftrightarrow> HOL.equal a b"
    and "HOL.equal (Val a) (Env y g) \<longleftrightarrow> False"
    and "HOL.equal (Env x f) (Val b) \<longleftrightarrow> False"
proof (unfold equal)
  have "f = g \<longleftrightarrow>
    (\<forall>z. case f z of
      None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
    | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" (is "?lhs = ?rhs")
  proof
    assume ?lhs
    then show ?rhs by (auto split: option.splits)
  next
    assume ?rhs (is "\<forall>z. ?prop z")
    show ?lhs
    proof
      fix z
      from \<open>?rhs\<close> have "?prop z" ..
      then show "f z = g z" by (auto split: option.splits)
    qed
  qed
  then show "Env x f = Env y g \<longleftrightarrow>
    x = y \<and> (\<forall>z \<in> UNIV.
      case f z of
        None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
      | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" by simp
qed simp_all

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

end


header {* \isaheader{Machine Words} *}
theory WordRefine
imports "../Refine_Monadic" "~~/src/HOL/Word/Word"
begin

text {* This theory provides a simple example to show refinement of natural
  numbers to machine words. The setup is not yet very elaborated, but shows
  the direction to go.
*}

subsection {* Setup *}
definition [simp]: "word_nat_rel \<equiv> build_rel (unat) (\<lambda>_. True)"
lemma word_nat_RELEATES[refine_dref_RELATES]:
  "RELATES word_nat_rel" by (simp add: RELATES_def)

lemma [simp, relator_props]:
  "single_valued word_nat_rel" unfolding word_nat_rel_def
  by blast

lemma [simp, relator_props]: "single_valued (converse word_nat_rel)"
  unfolding word_nat_rel_def
  apply (auto simp del: build_rel_def)
  by (metis injI order_antisym order_eq_refl word_le_nat_alt)

lemmas [refine_hsimp] =
  word_less_nat_alt word_le_nat_alt unat_sub iffD1[OF unat_add_lem]

subsection {* Example *}
type_synonym word32 = "32 word"

definition test :: "nat \<Rightarrow> nat \<Rightarrow> nat set nres" where "test x0 y0 \<equiv> do {
  let S={};
  (S,_,_) \<leftarrow> WHILE (\<lambda>(S,x,y). x>0) (\<lambda>(S,x,y). do {
    let S=S\<union>{y};
    let x=x - 1;
    ASSERT (y<x0+y0);
    let y=y + 1;
    RETURN (S,x,y)
  }) (S,x0,y0);
  RETURN S
}"

lemma "y0>0 \<Longrightarrow> test x0 y0 \<le> SPEC (\<lambda>S. S={y0 .. y0 + x0 - 1})"
  -- "Choosen pre-condition to get least trouble when proving"
  unfolding test_def
  apply (intro WHILE_rule[where I="\<lambda>(S,x,y).
    x+y=x0+y0 \<and> x\<le>x0 \<and>
    S={y0 .. y0 + (x0-x) - 1}"]
    refine_vcg)
  by auto

definition test_impl :: "word32 \<Rightarrow> word32 \<Rightarrow> word32 set nres" where
  "test_impl x y \<equiv> do {
    let S={};
    (S,_,_) \<leftarrow> WHILE (\<lambda>(S,x,y). x>0) (\<lambda>(S,x,y). do {
      let S=S\<union>{y};
      let x=x - 1;
      let y=y + 1;
      RETURN (S,x,y)
    }) (S,x,y);
    RETURN S
  }"

end


(*<*)
theory TAO_99_SanityTests
imports TAO_7_Axioms
begin
(*>*)

section\<open>Sanity Tests\<close>
text\<open>\label{TAO_SanityTests}\<close>

locale SanityTests
begin
  interpretation MetaSolver.
  interpretation Semantics.

subsection\<open>Consistency\<close>
text\<open>\label{TAO_SanityTests_Consistency}\<close>

  lemma "True"
    nitpick[expect=genuine, user_axioms, satisfy]
    by auto

subsection\<open>Intensionality\<close>
text\<open>\label{TAO_SanityTests_Intensionality}\<close>

  lemma "[(\<^bold>\<lambda>y. (q \<^bold>\<or> \<^bold>\<not>q)) \<^bold>= (\<^bold>\<lambda>y. (p \<^bold>\<or> \<^bold>\<not>p)) in v]"
    unfolding identity_\<Pi>\<^sub>1_def conn_defs
    apply (rule Eq\<^sub>1I) apply (simp add: meta_defs)
    nitpick[expect = genuine, user_axioms=true, card i = 2,
            card j = 2, card \<omega> = 1, card \<sigma> = 1,
            sat_solver = MiniSat_JNI, verbose, show_all]
    oops \<comment> \<open>Countermodel by Nitpick\<close>
  lemma "[(\<^bold>\<lambda>y. (p \<^bold>\<or> q)) \<^bold>= (\<^bold>\<lambda>y. (q \<^bold>\<or> p)) in v]"
    unfolding identity_\<Pi>\<^sub>1_def
    apply (rule Eq\<^sub>1I) apply (simp add: meta_defs)
    nitpick[expect = genuine, user_axioms=true,
            sat_solver = MiniSat_JNI, card i = 2,
            card j = 2, card \<sigma> = 1, card \<omega> = 1,
            card \<upsilon> = 2, verbose, show_all]
    oops \<comment> \<open>Countermodel by Nitpick\<close>

subsection\<open>Concreteness coindices with Object Domains\<close>
text\<open>\label{TAO_SanityTests_Concreteness}\<close>

  lemma OrdCheck:
    "[\<lparr>\<^bold>\<lambda> x . \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>\<lparr>E!, x\<^sup>P\<rparr>), x\<rparr> in v] \<longleftrightarrow>
     (proper x) \<and> (case (rep x) of \<omega>\<nu> y \<Rightarrow> True | _ \<Rightarrow> False)"
    using OrdinaryObjectsPossiblyConcreteAxiom
    apply (simp add: meta_defs meta_aux split: \<nu>.split \<upsilon>.split)
    using \<nu>\<upsilon>_\<omega>\<nu>_is_\<omega>\<upsilon> by fastforce
  lemma AbsCheck:
    "[\<lparr>\<^bold>\<lambda> x . \<^bold>\<box>(\<^bold>\<not>\<lparr>E!, x\<^sup>P\<rparr>), x\<rparr> in v] \<longleftrightarrow>
     (proper x) \<and> (case (rep x) of \<alpha>\<nu> y \<Rightarrow> True | _ \<Rightarrow> False)"
    using OrdinaryObjectsPossiblyConcreteAxiom
    apply (simp add: meta_defs meta_aux split: \<nu>.split \<upsilon>.split)
    using no_\<alpha>\<omega> by blast

subsection\<open>Justification for Meta-Logical Axioms\<close>
text\<open>\label{TAO_SanityTests_MetaAxioms}\<close>

text\<open>
\begin{remark}
  OrdinaryObjectsPossiblyConcreteAxiom is equivalent to "all ordinary objects are
   possibly concrete".
\end{remark}
\<close>
  lemma OrdAxiomCheck:
    "OrdinaryObjectsPossiblyConcrete \<longleftrightarrow>
      (\<forall> x. ([\<lparr>\<^bold>\<lambda> x . \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>\<lparr>E!, x\<^sup>P\<rparr>), x\<^sup>P\<rparr> in v]
       \<longleftrightarrow> (case x of \<omega>\<nu> y \<Rightarrow> True | _ \<Rightarrow> False)))"
    unfolding Concrete_def
    apply (simp add: meta_defs meta_aux split: \<nu>.split \<upsilon>.split)
    using \<nu>\<upsilon>_\<omega>\<nu>_is_\<omega>\<upsilon> by fastforce

text\<open>
\begin{remark}
  OrdinaryObjectsPossiblyConcreteAxiom is equivalent to "all abstract objects are
  necessarily not concrete".
\end{remark}
\<close>

  lemma AbsAxiomCheck:
    "OrdinaryObjectsPossiblyConcrete \<longleftrightarrow>
      (\<forall> x. ([\<lparr>\<^bold>\<lambda> x . \<^bold>\<box>(\<^bold>\<not>\<lparr>E!, x\<^sup>P\<rparr>), x\<^sup>P\<rparr> in v]
       \<longleftrightarrow> (case x of \<alpha>\<nu> y \<Rightarrow> True | _ \<Rightarrow> False)))"
    apply (simp add: meta_defs meta_aux split: \<nu>.split \<upsilon>.split)
    using \<nu>\<upsilon>_\<omega>\<nu>_is_\<omega>\<upsilon> no_\<alpha>\<omega> by fastforce

text\<open>
\begin{remark}
  PossiblyContingentObjectExistsAxiom is equivalent to the corresponding statement
  in the embedded logic.
\end{remark}
\<close>

  lemma PossiblyContingentObjectExistsCheck:
    "PossiblyContingentObjectExists \<longleftrightarrow> [\<^bold>\<not>(\<^bold>\<box>(\<^bold>\<forall> x. \<lparr>E!,x\<^sup>P\<rparr> \<^bold>\<rightarrow> \<^bold>\<box>\<lparr>E!,x\<^sup>P\<rparr>)) in v]"
     apply (simp add: meta_defs forall_\<nu>_def meta_aux split: \<nu>.split \<upsilon>.split)
     by (metis \<nu>.simps(5) \<nu>\<upsilon>_def \<upsilon>.simps(1) no_\<sigma>\<omega> \<upsilon>.exhaust)

text\<open>
\begin{remark}
  PossiblyNoContingentObjectExistsAxiom is equivalent to the corresponding statement
  in the embedded logic.
\end{remark}
\<close>

  lemma PossiblyNoContingentObjectExistsCheck:
    "PossiblyNoContingentObjectExists \<longleftrightarrow> [\<^bold>\<not>(\<^bold>\<box>(\<^bold>\<not>(\<^bold>\<forall> x. \<lparr>E!,x\<^sup>P\<rparr> \<^bold>\<rightarrow> \<^bold>\<box>\<lparr>E!,x\<^sup>P\<rparr>))) in v]"
    apply (simp add: meta_defs forall_\<nu>_def meta_aux split: \<nu>.split \<upsilon>.split)
    using \<nu>\<upsilon>_\<omega>\<nu>_is_\<omega>\<upsilon> by blast

subsection\<open>Relations in the Meta-Logic\<close>
text\<open>\label{TAO_SanityTests_MetaRelations}\<close>

text\<open>
\begin{remark}
  Material equality in the embedded logic corresponds to
  equality in the actual state in the meta-logic.
\end{remark}
\<close>

  lemma mat_eq_is_eq_dj:
    "[\<^bold>\<forall> x . \<^bold>\<box>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,x\<^sup>P\<rparr>) in v] \<longleftrightarrow>
     ((\<lambda> x . (eval\<Pi>\<^sub>1 F) x dj) = (\<lambda> x . (eval\<Pi>\<^sub>1 G) x dj))"
  proof
    assume 1: "[\<^bold>\<forall>x. \<^bold>\<box>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,x\<^sup>P\<rparr>) in v]"
    {
      fix v
      fix y
      obtain x where y_def: "y = \<nu>\<upsilon> x"
        by (meson \<nu>\<upsilon>_surj surj_def)
      have "(\<exists>r o\<^sub>1. Some r = d\<^sub>1 F \<and> Some o\<^sub>1 = d\<^sub>\<kappa> (x\<^sup>P) \<and> o\<^sub>1 \<in> ex1 r v) =
            (\<exists>r o\<^sub>1. Some r = d\<^sub>1 G \<and> Some o\<^sub>1 = d\<^sub>\<kappa> (x\<^sup>P) \<and> o\<^sub>1 \<in> ex1 r v)"
            using 1 apply - by meta_solver
      moreover obtain r where r_def: "Some r = d\<^sub>1 F"
        unfolding d\<^sub>1_def by auto
      moreover obtain s where s_def: "Some s = d\<^sub>1 G"
        unfolding d\<^sub>1_def by auto
      moreover have "Some x = d\<^sub>\<kappa> (x\<^sup>P)"
        using d\<^sub>\<kappa>_proper by simp
      ultimately have "(x \<in> ex1 r v) = (x \<in> ex1 s v)"
        by (metis option.inject)
      hence "(eval\<Pi>\<^sub>1 F) y dj v = (eval\<Pi>\<^sub>1 G) y dj v"
        using r_def s_def y_def by (simp add: d\<^sub>1.rep_eq ex1_def)
    }
    thus "(\<lambda>x. eval\<Pi>\<^sub>1 F x dj) = (\<lambda>x. eval\<Pi>\<^sub>1 G x dj)"
      by auto
  next
    assume 1: "(\<lambda>x. eval\<Pi>\<^sub>1 F x dj) = (\<lambda>x. eval\<Pi>\<^sub>1 G x dj)"
    {
      fix y v
      obtain x where x_def: "x = \<nu>\<upsilon> y"
        by simp
      hence "eval\<Pi>\<^sub>1 F x dj = eval\<Pi>\<^sub>1 G x dj"
        using 1 by metis
      moreover obtain r where r_def: "Some r = d\<^sub>1 F"
        unfolding d\<^sub>1_def by auto
      moreover obtain s where s_def: "Some s = d\<^sub>1 G"
        unfolding d\<^sub>1_def by auto
      ultimately have "(y \<in> ex1 r v) = (y \<in> ex1 s v)"
        by (simp add: d\<^sub>1.rep_eq ex1_def \<nu>\<upsilon>_surj x_def)
      hence "[\<lparr>F,y\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,y\<^sup>P\<rparr> in v]"
        apply - apply meta_solver
        using r_def s_def by (metis Semantics.d\<^sub>\<kappa>_proper option.inject)
    }
    thus "[\<^bold>\<forall>x. \<^bold>\<box>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,x\<^sup>P\<rparr>) in v]"
      using T6 T8 by fast
  qed

text\<open>
\begin{remark}
  Materially equivalent relations are equal in the embedded logic
  if and only if they also coincide in all other states.
\end{remark}
\<close>

  lemma mat_eq_is_eq_if_eq_forall_j:
    assumes "[\<^bold>\<forall> x . \<^bold>\<box>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,x\<^sup>P\<rparr>) in v]"
    shows "[F \<^bold>= G in v] \<longleftrightarrow>
           (\<forall> s . s \<noteq> dj \<longrightarrow> (\<forall> x . (eval\<Pi>\<^sub>1 F) x s = (eval\<Pi>\<^sub>1 G) x s))"
    proof
      interpret MetaSolver .
      assume "[F \<^bold>= G in v]"
      hence "F = G"
        apply - unfolding identity_\<Pi>\<^sub>1_def by meta_solver
      thus "\<forall>s. s \<noteq> dj \<longrightarrow> (\<forall>x. eval\<Pi>\<^sub>1 F x s = eval\<Pi>\<^sub>1 G x s)"
        by auto
    next
      interpret MetaSolver .
      assume "\<forall>s. s \<noteq> dj \<longrightarrow> (\<forall>x. eval\<Pi>\<^sub>1 F x s = eval\<Pi>\<^sub>1 G x s)"
      moreover have "((\<lambda> x . (eval\<Pi>\<^sub>1 F) x dj) = (\<lambda> x . (eval\<Pi>\<^sub>1 G) x dj))"
        using assms mat_eq_is_eq_dj by auto
      ultimately have "\<forall>s x. eval\<Pi>\<^sub>1 F x s = eval\<Pi>\<^sub>1 G x s"
        by metis
      hence "eval\<Pi>\<^sub>1 F = eval\<Pi>\<^sub>1 G"
        by blast
      hence "F = G"
        by (metis eval\<Pi>\<^sub>1_inverse)
      thus "[F \<^bold>= G in v]"
        unfolding identity_\<Pi>\<^sub>1_def using Eq\<^sub>1I by auto
    qed

text\<open>
\begin{remark}
  Under the assumption that all properties behave in all states like in the actual state
  the defined equality degenerates to material equality.
\end{remark}
\<close>

  lemma assumes "\<forall> F x s . (eval\<Pi>\<^sub>1 F) x s = (eval\<Pi>\<^sub>1 F) x dj"
    shows "[\<^bold>\<forall> x . \<^bold>\<box>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>G,x\<^sup>P\<rparr>) in v] \<longleftrightarrow> [F \<^bold>= G in v]"
    by (metis (no_types) MetaSolver.Eq\<^sub>1S assms identity_\<Pi>\<^sub>1_def
                         mat_eq_is_eq_dj mat_eq_is_eq_if_eq_forall_j)

subsection\<open>Lambda Expressions\<close>
text\<open>\label{TAO_SanityTests_MetaLambda}\<close>

  lemma lambda_interpret_1:
  assumes "[a \<^bold>= b in v]"
  shows "(\<^bold>\<lambda>x. \<lparr>R,x\<^sup>P,a\<rparr>) = (\<^bold>\<lambda>x . \<lparr>R,x\<^sup>P, b\<rparr>)"
  proof -
    have "a = b"
      using MetaSolver.Eq\<kappa>S Semantics.d\<^sub>\<kappa>_inject assms
            identity_\<kappa>_def by auto
    thus ?thesis by simp
  qed

  lemma lambda_interpret_2:
  assumes "[a \<^bold>= (\<^bold>\<iota>y. \<lparr>G,y\<^sup>P\<rparr>) in v]"
  shows "(\<^bold>\<lambda>x. \<lparr>R,x\<^sup>P,a\<rparr>) = (\<^bold>\<lambda>x . \<lparr>R,x\<^sup>P, \<^bold>\<iota>y. \<lparr>G,y\<^sup>P\<rparr>\<rparr>)"
  proof -
    have "a = (\<^bold>\<iota>y. \<lparr>G,y\<^sup>P\<rparr>)"
      using MetaSolver.Eq\<kappa>S Semantics.d\<^sub>\<kappa>_inject assms
            identity_\<kappa>_def by auto
    thus ?thesis by simp
  qed

end

(*<*)
end
(*>*)


(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Tree relabelling\<close>

theory Tree_Relabelling imports
  Applicative_State
  Applicative_Option
  Applicative_PMF
  "HOL-Library.Stream"
begin

unbundle applicative_syntax
adhoc_overloading Applicative.pure pure_option
adhoc_overloading Applicative.pure State_Monad.return
adhoc_overloading Applicative.ap State_Monad.ap

text \<open> Hutton and Fulger \cite{HuttonFulger2008TFP} suggested the following tree relabelling problem
  as an example for reasoning about effects. Given a binary tree with labels at the leaves, the
  relabelling assigns a unique number to every leaf.  Their correctness property states that the
  list of labels in the obtained tree is distinct.  As observed by Gibbons and Bird \cite{backwards},
  this breaks the abstraction of the state monad, because the relabeling function must be run.
  Although Hutton and Fulger are careful to reason in point-free style, they nevertheless unfold
  the implementation of the state monad operations.  Gibbons and Hinze \cite{GibbonsHinze2011ICFP}
  suggest to state the correctness in an effectful way using an exception-state monad.  Thereby, they
  lose the applicative structure and have to resort to a full monad.

  Here, we model the tree relabelling function three times. First, we state correctness in pure
  terms following Hutton and Fulger.  Second, we take Gibbons' and Bird's approach of considering
  traversals. Third, we state correctness effectfully, but only using the applicative functors.
\<close>

datatype 'a tree = Leaf 'a | Node "'a tree" "'a tree"

primrec fold_tree :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a tree \<Rightarrow> 'b"
where
  "fold_tree f g (Leaf a) = f a"
| "fold_tree f g (Node l r) = g (fold_tree f g l) (fold_tree f g r)"

definition leaves :: "'a tree \<Rightarrow> nat"
where "leaves = fold_tree (\<lambda>_. 1) (+)"

lemma leaves_simps [simp]:
  "leaves (Leaf x) = Suc 0"
  "leaves (Node l r) = leaves l + leaves r"
by(simp_all add: leaves_def)

subsubsection \<open>Pure correctness statement\<close>

definition labels :: "'a tree \<Rightarrow> 'a list"
where "labels = fold_tree (\<lambda>x. [x]) append"

lemma labels_simps [simp]:
  "labels (Leaf x) = [x]"
  "labels (Node l r) = labels l @ labels r"
by(simp_all add: labels_def)

locale labelling =
  fixes fresh :: "('s, 'x) state"
begin

declare [[show_variants]]

definition label_tree :: "'a tree \<Rightarrow> ('s, 'x tree) state"
where "label_tree = fold_tree (\<lambda>_ :: 'a. pure Leaf \<diamondop> fresh) (\<lambda>l r. pure Node \<diamondop> l \<diamondop> r)"

lemma label_tree_simps [simp]:
  "label_tree (Leaf x) = pure Leaf \<diamondop> fresh"
  "label_tree (Node l r) = pure Node \<diamondop> label_tree l \<diamondop> label_tree r"
by(simp_all add: label_tree_def)

primrec label_list :: "'a list \<Rightarrow> ('s, 'x list) state"
where
    "label_list [] = pure []"
  | "label_list (x # xs) = pure (#) \<diamondop> fresh \<diamondop> label_list xs"

lemma label_append: "label_list (a @ b) = pure (@) \<diamondop> label_list a \<diamondop> label_list b"
  \<comment> \<open>The proof lifts the defining equations of @{const append} to the state monad.\<close>
proof (induction a)
  case Nil
  show ?case
    unfolding append.simps label_list.simps
    by applicative_nf simp
next
  case (Cons a1 a2)
  show ?case
    unfolding append.simps label_list.simps Cons.IH
    by applicative_nf simp
qed

lemma label_tree_list: "pure labels \<diamondop> label_tree t = label_list (labels t)"
proof (induction t)
  case Leaf show ?case unfolding label_tree_simps labels_simps label_list.simps
    by applicative_nf simp
next
  case Node show ?case unfolding label_tree_simps labels_simps label_append Node.IH[symmetric]
    by applicative_nf simp
qed

text \<open>We directly show correctness without going via streams like Hutton and Fulger \cite{HuttonFulger2008TFP}. \<close>

lemma correctness_pure:
  fixes t :: "'a tree"
  assumes distinct: "\<And>xs :: 'a list. distinct (fst (run_state (label_list xs) s))"
  shows "distinct (labels (fst (run_state (label_tree t) s)))"
using label_tree_list[of t, THEN arg_cong, of "\<lambda>f. run_state f s"] assms[of "labels t"]
by(cases "run_state (label_list (labels t)) s")(simp add: State_Monad.ap_def split_beta)

end

subsubsection \<open>Correctness via monadic traversals\<close>

text \<open>Dual version of an applicative functor with effects composed in the opposite order\<close>

typedef 'a dual = "UNIV :: 'a set" morphisms un_B B by blast
setup_lifting type_definition_dual

lift_definition pure_dual :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b dual"
is "\<lambda>pure. pure" .

lift_definition ap_dual :: "(('a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b) \<Rightarrow> 'af1) \<Rightarrow> ('af1 \<Rightarrow> 'af3 \<Rightarrow> 'af13) \<Rightarrow> ('af13 \<Rightarrow> 'af2 \<Rightarrow> 'af) \<Rightarrow> 'af2 dual \<Rightarrow> 'af3 dual \<Rightarrow> 'af dual"
is "\<lambda>pure ap1 ap2 f x. ap2 (ap1 (pure (\<lambda>x f. f x)) x) f" .

type_synonym ('s, 'a) state_rev = "('s, 'a) state dual"

definition pure_state_rev :: "'a \<Rightarrow> ('s, 'a) state_rev"
where "pure_state_rev = pure_dual State_Monad.return"

definition ap_state_rev :: "('s, 'a \<Rightarrow> 'b) state_rev \<Rightarrow> ('s, 'a) state_rev \<Rightarrow> ('s, 'b) state_rev"
where "ap_state_rev = ap_dual State_Monad.return State_Monad.ap State_Monad.ap"

adhoc_overloading Applicative.pure pure_state_rev
adhoc_overloading Applicative.ap ap_state_rev

applicative state_rev
for
  pure: pure_state_rev
  ap: ap_state_rev
unfolding pure_state_rev_def ap_state_rev_def by(transfer, applicative_nf, rule refl)+

type_synonym ('s, 'a) state_rev_rev = "('s, 'a) state_rev dual"

definition pure_state_rev_rev :: "'a \<Rightarrow> ('s, 'a) state_rev_rev"
where "pure_state_rev_rev = pure_dual pure_state_rev"

definition ap_state_rev_rev :: "('s, 'a \<Rightarrow> 'b) state_rev_rev \<Rightarrow> ('s, 'a) state_rev_rev \<Rightarrow> ('s, 'b) state_rev_rev"
where "ap_state_rev_rev = ap_dual pure_state_rev ap_state_rev ap_state_rev"

adhoc_overloading Applicative.pure pure_state_rev_rev
adhoc_overloading Applicative.ap ap_state_rev_rev

applicative state_rev_rev
for
  pure: pure_state_rev_rev
  ap: ap_state_rev_rev
unfolding pure_state_rev_rev_def ap_state_rev_rev_def by(transfer, applicative_nf, rule refl)+

lemma ap_state_rev_B: "B f \<diamondop> B x = B (State_Monad.return (\<lambda>x f. f x) \<diamondop> x \<diamondop> f)"
unfolding ap_state_rev_def by(fact ap_dual.abs_eq)

lemma ap_state_rev_pure_B: "pure f \<diamondop> B x = B (State_Monad.return f \<diamondop> x)"
unfolding ap_state_rev_def pure_state_rev_def
by transfer(applicative_nf, rule refl)

lemma ap_state_rev_rev_B: "B f \<diamondop> B x = B (pure_state_rev (\<lambda>x f. f x) \<diamondop> x \<diamondop> f)"
unfolding ap_state_rev_rev_def by(fact ap_dual.abs_eq)

lemma ap_state_rev_rev_pure_B: "pure f \<diamondop> B x = B (pure_state_rev f \<diamondop> x)"
unfolding ap_state_rev_rev_def pure_state_rev_rev_def
by transfer(applicative_nf, rule refl)

text \<open>
  The formulation by Gibbons and Bird \cite{backwards} crucially depends on Kleisli composition,
  so we need the state monad rather than the applicative functor only.
\<close>

lemma ap_conv_bind_state: "State_Monad.ap f x = State_Monad.bind f (\<lambda>f. State_Monad.bind x (State_Monad.return \<circ> f))"
by(simp add: State_Monad.ap_def State_Monad.bind_def Let_def split_def o_def fun_eq_iff)

lemma ap_pure_bind_state: "pure x \<diamondop> State_Monad.bind y f = State_Monad.bind y ((\<diamondop>) (pure x) \<circ> f)"
by(simp add: ap_conv_bind_state o_def)

definition kleisli_state :: "('b \<Rightarrow> ('s, 'c) state) \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a \<Rightarrow> ('s, 'c) state" (infixl "\<bullet>" 55)
where [simp]: "kleisli_state g f a = State_Monad.bind (f a) g"

definition fetch :: "('a stream, 'a) state"
where "fetch = State_Monad.bind State_Monad.get (\<lambda>s. State_Monad.bind (State_Monad.set (stl s)) (\<lambda>_. State_Monad.return (shd s)))"

primrec traverse :: "('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state"
where
  "traverse f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse f (Node l r) = pure Node \<diamondop> traverse f l \<diamondop> traverse f r"

text \<open>As we cannot abstract over the applicative functor in definitions, we define
  traversal on the transformed applicative function once again.\<close>

primrec traverse_rev :: "('a \<Rightarrow> ('s, 'b) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev"
where
  "traverse_rev f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse_rev f (Node l r) = pure Node \<diamondop> traverse_rev f l \<diamondop> traverse_rev f r"

definition recurse :: "('a \<Rightarrow> ('s, 'b) state) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state"
where "recurse f = un_B \<circ> traverse_rev (B \<circ> f)"

lemma recurse_Leaf: "recurse f (Leaf x) = pure Leaf \<diamondop> f x"
unfolding recurse_def traverse_rev.simps o_def ap_state_rev_pure_B
by(simp add: B_inverse)

lemma recurse_Node:
  "recurse f (Node l r) = pure (\<lambda>r l. Node l r) \<diamondop> recurse f r \<diamondop> recurse f l"
proof -
  have "recurse f (Node l r) = un_B (pure Node \<diamondop> traverse_rev (B \<circ> f) l \<diamondop> traverse_rev (B \<circ> f) r)"
    by(simp add: recurse_def)
  also have "\<dots> = un_B (B (pure Node) \<diamondop> B (recurse f l) \<diamondop> B (recurse f r))"
    by(simp add: un_B_inverse recurse_def pure_state_rev_def pure_dual_def)
  also have "\<dots> = pure (\<lambda>x f. f x) \<diamondop> recurse f r \<diamondop> (pure (\<lambda>x f. f x) \<diamondop> recurse f l \<diamondop> pure Node)"
    by(simp add: ap_state_rev_B B_inverse)
  also have "\<dots> = pure (\<lambda>r l. Node l r) \<diamondop> recurse f r \<diamondop> recurse f l"
    \<comment> \<open>This step expands to 13 steps in \cite{backwards}\<close>
    by(applicative_nf) simp
  finally show ?thesis .
qed

lemma traverse_pure: "traverse pure t = pure t"
proof(induction t)
  { case Leaf show ?case unfolding traverse.simps by applicative_nf simp }
  { case Node show ?case unfolding traverse.simps Node.IH by applicative_nf simp }
qed

text \<open>@{term "B \<circ> B"} is an idiom morphism\<close>

lemma B_pure: "pure x = B (State_Monad.return x)"
unfolding pure_state_rev_def by transfer simp

lemma BB_pure: "pure x = B (B (pure x))"
unfolding pure_state_rev_rev_def B_pure[symmetric] by transfer(rule refl)

lemma BB_ap: "B (B f) \<diamondop> B (B x) = B (B (f \<diamondop> x))"
proof -
  have "B (B f) \<diamondop> B (B x) = B (B (pure (\<lambda>x f. f x) \<diamondop> f \<diamondop> (pure (\<lambda>x f. f x) \<diamondop> x \<diamondop> pure (\<lambda>x f. f x))))"
    (is "_ = B (B ?exp)")
    unfolding ap_state_rev_rev_B B_pure ap_state_rev_B ..
  also have "?exp = f \<diamondop> x" \<comment> \<open>This step takes 15 steps in \cite{backwards}.\<close>
    by(applicative_nf)(rule refl)
  finally show ?thesis .
qed

primrec traverse_rev_rev :: "('a \<Rightarrow> ('s, 'b) state_rev_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev_rev"
where
  "traverse_rev_rev f (Leaf x) = pure Leaf \<diamondop> f x"
| "traverse_rev_rev f (Node l r) = pure Node \<diamondop> traverse_rev_rev f l \<diamondop> traverse_rev_rev f r"

definition recurse_rev :: "('a \<Rightarrow> ('s, 'b) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('s, 'b tree) state_rev"
where "recurse_rev f = un_B \<circ> traverse_rev_rev (B \<circ> f)"

lemma traverse_B_B: "traverse_rev_rev (B \<circ> B \<circ> f) = B \<circ> B \<circ> traverse f" (is "?lhs = ?rhs")
proof
  fix t
  show "?lhs t = ?rhs t" by(induction t)(simp_all add: BB_pure BB_ap)
qed

lemma traverse_recurse: "traverse f = un_B \<circ> recurse_rev (B \<circ> f)" (is "?lhs = ?rhs")
proof -
  have "?lhs = un_B \<circ> un_B \<circ> B \<circ> B \<circ> traverse f" by(simp add: o_def B_inverse)
  also have "\<dots> = un_B \<circ> un_B \<circ> traverse_rev_rev (B \<circ> B \<circ> f)" unfolding traverse_B_B by(simp add: o_assoc)
  also have "\<dots> = ?rhs" by(simp add: recurse_rev_def o_assoc)
  finally show ?thesis .
qed

lemma recurse_traverse:
  assumes "f \<bullet> g = pure"
  shows "recurse f \<bullet> traverse g = pure"
\<comment> \<open>Gibbons and Bird impose this as an additional requirement on traversals, but they write
  that they have not found a way to derive this fact from other axioms. So we prove it directly.\<close>
proof
  fix t
  from assms have *: "\<And>x. State_Monad.bind (g x) f = State_Monad.return x" by(simp add: fun_eq_iff)
  hence **: "\<And>x h. State_Monad.bind (g x) (\<lambda>x. State_Monad.bind (f x) h) = h x"
    by(fold State_Monad.bind_assoc)(simp)
  show "(recurse f \<bullet> traverse g) t = pure t" unfolding kleisli_state_def
  proof(induction t)
    case (Leaf x)
    show ?case
      by(simp add: ap_conv_bind_state recurse_Leaf **)
  next
    case (Node l r)
    show ?case
      by(simp add: ap_conv_bind_state recurse_Node)(simp add: State_Monad.bind_assoc[symmetric] Node.IH)
  qed
qed

text \<open>Apply traversals to labelling\<close>

definition strip :: "'a \<times> 'b \<Rightarrow> ('b stream, 'a) state"
where "strip = (\<lambda>(a, b). State_Monad.bind (State_Monad.update (SCons b)) (\<lambda>_. State_Monad.return a))"

definition adorn :: "'a \<Rightarrow> ('b stream, 'a \<times> 'b) state"
where "adorn a = pure (Pair a) \<diamondop> fetch"

abbreviation label :: "'a tree \<Rightarrow> ('b stream, ('a \<times> 'b) tree) state"
where "label \<equiv> traverse adorn"

abbreviation unlabel :: "('a \<times> 'b) tree \<Rightarrow> ('b stream, 'a tree) state"
where "unlabel \<equiv> recurse strip"

lemma strip_adorn: "strip \<bullet> adorn = pure"
by(simp add: strip_def adorn_def fun_eq_iff fetch_def[abs_def] ap_conv_bind_state)

lemma correctness_monadic: "unlabel \<bullet> label = pure"
by(rule recurse_traverse)(rule strip_adorn)

subsubsection \<open>Applicative correctness statement\<close>

text \<open>Repeating an effect\<close>

primrec repeatM :: "nat \<Rightarrow> ('s, 'x) state \<Rightarrow> ('s, 'x list) state"
where
  "repeatM 0 f = State_Monad.return []"
| "repeatM (Suc n) f = pure (#) \<diamondop> f \<diamondop> repeatM n f"

lemma repeatM_plus: "repeatM (n + m) f = pure append \<diamondop> repeatM n f \<diamondop> repeatM m f"
by(induction n)(simp; applicative_nf; simp)+

abbreviation (input) fail :: "'a option" where "fail \<equiv> None"

definition lift_state :: "('s, 'a) state \<Rightarrow> ('s, 'a option) state"
where [applicative_unfold]: "lift_state x = pure pure \<diamondop> x"

definition lift_option :: "'a option \<Rightarrow> ('s, 'a option) state"
where [applicative_unfold]: "lift_option x = pure x"

fun assert :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option"
where
  assert_fail: "assert P fail = fail"
| assert_pure: "assert P (pure x) = (if P x then pure x else fail)"

context labelling begin

abbreviation symbols :: "nat \<Rightarrow> ('s, 'x list option) state"
where "symbols n \<equiv> lift_state (repeatM n fresh)"

abbreviation (input) disjoint :: "'x list \<Rightarrow> 'x list \<Rightarrow> bool"
where "disjoint xs ys \<equiv> set xs \<inter> set ys = {}"

definition dlabels :: "'x tree \<Rightarrow> 'x list option"
where "dlabels = fold_tree (\<lambda>x. pure [x])
     (\<lambda>l r. pure (case_prod append) \<diamondop> (assert (case_prod disjoint) (pure Pair \<diamondop> l \<diamondop> r)))"

lemma dlabels_simps [simp]:
  "dlabels (Leaf x) = pure [x]"
  "dlabels (Node l r) = pure (case_prod append) \<diamondop> (assert (case_prod disjoint) (pure Pair \<diamondop> dlabels l \<diamondop> dlabels r))"
by(simp_all add: dlabels_def)

lemma correctness_applicative:
  assumes distinct: "\<And>n. pure (assert distinct) \<diamondop> symbols n = symbols n"
  shows "State_Monad.return dlabels \<diamondop> label_tree t = symbols (leaves t)"
proof(induction t)
  show "pure dlabels \<diamondop> label_tree (Leaf x) = symbols (leaves (Leaf x))" for x :: 'a
    unfolding label_tree_simps leaves_simps repeatM.simps by applicative_nf simp
next
  fix l r :: "'a tree"
  assume IH: "pure dlabels \<diamondop> label_tree l = symbols (leaves l)" "pure dlabels \<diamondop> label_tree r = symbols (leaves r)"
  let ?cat = "case_prod append" and ?disj = "case_prod disjoint"
  let ?f = "\<lambda>l r. pure ?cat \<diamondop> (assert ?disj (pure Pair \<diamondop> l \<diamondop> r))"
  have "State_Monad.return dlabels \<diamondop> label_tree (Node l r) =
        pure ?f \<diamondop> (pure dlabels \<diamondop> label_tree l) \<diamondop> (pure dlabels \<diamondop> label_tree r)"
    unfolding label_tree_simps by applicative_nf simp
  also have "\<dots> = pure ?f \<diamondop> (pure (assert distinct) \<diamondop> symbols (leaves l)) \<diamondop> (pure (assert distinct) \<diamondop> symbols (leaves r))"
    unfolding IH distinct ..
  also have "\<dots> = pure (assert distinct) \<diamondop> symbols (leaves (Node l r))"
    unfolding leaves_simps repeatM_plus by applicative_nf simp
  also have "\<dots> = symbols (leaves (Node l r))" by(rule distinct)
  finally show "pure dlabels \<diamondop> label_tree (Node l r) = symbols (leaves (Node l r))" .
qed

end

subsubsection \<open>Probabilistic tree relabelling\<close>

primrec mirror :: "'a tree \<Rightarrow> 'a tree"
where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

datatype dir = Left | Right

hide_const (open) path

function (sequential) subtree :: "dir list \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
  "subtree (Left # path)  (Node l r) = subtree path l"
| "subtree (Right # path) (Node l r) = subtree path r"
| "subtree _              (Leaf x)   = Leaf x"
| "subtree []             t          = t"
by pat_completeness auto
termination by lexicographic_order

adhoc_overloading Applicative.pure pure_pmf

context fixes p :: "'a \<Rightarrow> 'b pmf" begin

primrec plabel :: "'a tree \<Rightarrow> 'b tree pmf"
where
  "plabel (Leaf x)   = pure Leaf \<diamondop> p x"
| "plabel (Node l r) = pure Node \<diamondop> plabel l \<diamondop> plabel r"

lemma plabel_mirror: "plabel (mirror t) = pure mirror \<diamondop> plabel t"
proof(induction t)
  case (Leaf x)
  show ?case unfolding plabel.simps mirror.simps by(applicative_lifting) simp
next
  case (Node t1 t2)
  show ?case unfolding plabel.simps mirror.simps Node.IH by(applicative_lifting) simp
qed

lemma plabel_subtree: "plabel (subtree path t) = pure (subtree path) \<diamondop> plabel t"
proof(induction path t rule: subtree.induct)
  case Left: (1 path l r)
  show ?case unfolding plabel.simps subtree.simps Left.IH by(applicative_lifting) simp
next
  case Right: (2 path l r)
  show ?case unfolding plabel.simps subtree.simps Right.IH by(applicative_lifting) simp
next
  case (3 uu x)
  show ?case unfolding plabel.simps subtree.simps by(applicative_lifting) simp
next
  case (4 v va)
  show ?case unfolding plabel.simps subtree.simps by(applicative_lifting) simp
qed

end

end


theory Prelude_Ord
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"DiffSymDef\",
     \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\", \"TE3\", \"TE4\",
     \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IOE04\", \"IOE05\",
     \"IOE06\", \"LeIrreflexivity\", \"LeTTransitive\", \"LeTTotal\",
     \"GeDef\", \"LeqDef\", \"GeqDef\", \"EqTSOrdRel\", \"EqFSOrdRel\",
     \"EqTOrdRel\", \"EqFOrdRel\", \"EqTOrdTSubstE\", \"EqTOrdFSubstE\",
     \"EqTOrdTSubstD\", \"EqTOrdFSubstD\", \"LeTGeFEqFRel\",
     \"LeFGeTEqTRel\", \"CmpLTDef\", \"CmpEQDef\", \"CmpGTDef\",
     \"MaxYDef\", \"MaxXDef\", \"MinXDef\", \"MinYDef\", \"IOO13\",
     \"IOO14\", \"IOO15\", \"IBO5\", \"IOE01\", \"IOE02\", \"IOE03\",
     \"IOE07\", \"IOE08\", \"IOE09\", \"LeTAsymmetry\",
     \"GeIrreflexivity\", \"GeTAsymmetry\", \"GeTTransitive\",
     \"GeTTotal\", \"LeqReflexivity\", \"LeqTTransitive\",
     \"LeqTTotal\", \"GeqReflexivity\", \"GeqTTransitive\",
     \"GeqTTotal\", \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\",
     \"LeqFGetFRel\", \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\",
     \"GeqFLeqFRel\", \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\",
     \"GeFLeTEqTRel\", \"GeqTLeFRel\", \"GeqFLeTRel\",
     \"LeqTLeTEqTRel\", \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\",
     \"GeqFGeFEqFRel\", \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\",
     \"MaxSym\", \"MinSym\", \"TO1\", \"TO2\", \"TO3\", \"TO4\",
     \"TO5\", \"TO6\", \"TO7\", \"IUO01\", \"IUO02\", \"IUO03\",
     \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"IOO16\", \"IOO17\",
     \"IOO18\", \"IOO19\", \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\",
     \"IOO24\", \"IOO25\", \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\",
     \"IOO30\", \"IOO31\", \"IOO32\", \"IOO33\", \"IBO6\", \"IBO7\",
     \"IBO8\", \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\"]"

typedecl Bool
typedecl Unit
typedecl X_Nat

datatype Ordering = EQ | GT | LT

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a partial => 'a partial => bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a partial => 'a partial => bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a partial => 'a partial => bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a partial => 'a partial => bool" ("(_/ <''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
X_max :: "'a partial => 'a partial => 'a partial"
X_min :: "'a partial => 'a partial => 'a partial"
compare :: "'a partial => 'a partial => Ordering partial"
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

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"

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

NotTrue1 [rule_format] : "ALL x. ~ Not' x = x"

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

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

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

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

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

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

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 = Not' (x ==' y)"

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

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

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

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

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

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

IUE2 [rule_format] : "~ makePartial () /= makePartial ()"

IBE1 [rule_format] : "makePartial () ==' makePartial ()"

IBE2 [rule_format] : "undefinedOp ==' undefinedOp"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

IBE4 [rule_format] : "~ makePartial () ==' undefinedOp"

IBE5 [rule_format] : "makePartial () /= undefinedOp"

IBE6 [rule_format] : "undefinedOp /= makePartial ()"

IBE7 [rule_format] : "Not' (makePartial () ==' undefinedOp)"

IBE8 [rule_format] : "~ Not' Not' (makePartial () ==' undefinedOp)"

IOE04 [rule_format] : "~ makePartial LT ==' makePartial EQ"

IOE05 [rule_format] : "~ makePartial LT ==' makePartial GT"

IOE06 [rule_format] : "~ makePartial EQ ==' makePartial GT"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

IOO13 [rule_format] : "makePartial LT <' makePartial EQ"

IOO14 [rule_format] : "makePartial EQ <' makePartial GT"

IOO15 [rule_format] : "makePartial LT <' makePartial GT"

IBO5 [rule_format] : "undefinedOp <' makePartial ()"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IUE1 [simp]
declare IUE2 [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 IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare LeIrreflexivity [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IBO5 [simp]

theorem IOE01 : "makePartial LT ==' makePartial LT"
by (auto)

ML "Header.record \"IOE01\""

theorem IOE02 : "makePartial EQ ==' makePartial EQ"
by (auto)

ML "Header.record \"IOE02\""

theorem IOE03 : "makePartial GT ==' makePartial GT"
by (auto)

ML "Header.record \"IOE03\""

theorem IOE07 : "makePartial LT /= makePartial EQ"
apply(simp add: DiffDef)
done

ML "Header.record \"IOE07\""

theorem IOE08 : "makePartial LT /= makePartial GT"
apply(simp add: DiffDef)
done

ML "Header.record \"IOE08\""

theorem IOE09 : "makePartial EQ /= makePartial GT"
apply(simp add: DiffDef)
done

ML "Header.record \"IOE09\""

lemma LeIrreflContra : "ALL x. x <' x ==> False"
by auto

theorem LeTAsymmetry : "ALL x. ALL y. x <' y --> ~ y <' x"
sorry

ML "Header.record \"LeTAsymmetry\""

theorem GeIrreflexivity : "ALL x. ALL y. x ==' y --> ~ x >' y"
apply (auto)
apply(simp add: GeDef)
apply(simp add: EqualSymDef LeIrreflexivity)
done

ML "Header.record \"GeIrreflexivity\""

theorem GeTAsymmetry : "ALL x. ALL y. x >' y --> ~ y >' x"
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeTAsymmetry)
done

ML "Header.record \"GeTAsymmetry\""

theorem GeTTransitive :
"ALL x. ALL y. ALL z. (x >' y) && (y >' z) --> x >' z"
apply(auto)
apply(simp add: GeDef)
thm LeTTransitive
apply(rule_tac x="(ab, bb)" and y="(aa, ba)" and z="(a,b)" in  LeTTransitive)
apply(auto)
apply(case_tac  "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac  "(aa, ba) <' (a, b)")
by(auto)

ML "Header.record \"GeTTransitive\""

theorem GeTTotal :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y)"
apply(auto)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeFGeTEqTRel)
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeTAsymmetry)
apply(simp add: EqualSymDef)
done

ML "Header.record \"GeTTotal\""

theorem LeqReflexivity : "ALL x. x <=' x"
apply(auto)
apply(simp add: LeqDef)
apply(simp add: OrDef)
done

ML "Header.record \"LeqReflexivity\""

lemma EqualL1 [rule_format]:
"ALL a b ab bb.
 ((a, b) ==' (ab, bb)) & ~ ((a, b) ==' (ab, bb)) \<longrightarrow> False"
by(auto)

lemma EqualL2 [rule_format]:
"ALL a b aa ab ba bb.
((a, b) ==' (aa, ba)) & ((aa, ba) ==' (ab, bb)) \<longrightarrow> ~ ((a, b) ==' (ab, bb)) \<longrightarrow> False"
apply(simp add: EqualL1)
apply(auto)
apply(rule EqualTransT)
by(auto)

lemma EqualL3 [rule_format]:
"ALL a b aa ab ba bb.
~ ((a, b) ==' (aa, ba)) | ~ ((aa, ba) ==' (ab, bb)) | ~ ((a, b) ==' (ab, bb)) \<longrightarrow> False \<longrightarrow> False"
by(auto)

lemma Le1E [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ((a, b) <' (ab, bb)) \<longrightarrow> ((aa, ba) <' (ab, bb))"
apply (auto)
apply(rule EqTOrdTSubstE)
by(auto)

lemma Le2 [rule_format]:
"ALL a b aa ab ba bb.
((a, b) <' (aa, ba)) \<longrightarrow> ~ ((a, b) <' (aa, ba)) \<longrightarrow> False"
by auto

lemma Le3E [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ((a, b) <' (ab, bb)) \<longrightarrow> ~ ((aa, ba) <' (ab, bb)) \<longrightarrow> False"
apply (auto)
apply(rule EqTOrdTSubstE)
by(auto)

lemma Le3D [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ((ab, bb) <' (a, b)) \<longrightarrow> ~ ((ab, bb) <' (aa, ba)) \<longrightarrow> False"
apply (auto)
apply(rule EqTOrdTSubstD)
apply(auto)
done

lemma Le4E [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ~ ((a, b) <' (ab, bb)) \<longrightarrow> ~ ((aa, ba) <' (ab, bb))"
apply (auto)
apply(rule Le3E)
apply(auto)
apply(simp add: EqualSymDef)
done

lemma Le4D [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ~ ((ab, bb) <' (a, b)) \<longrightarrow> ~ ((ab, bb) <' (aa, ba))"
apply (auto)
apply(rule Le3D)
apply(auto)
apply(simp add: EqualSymDef)
done

lemma Le5 [rule_format]:
"ALL a b aa ab ba bb.
~ ((a, b) <' (aa, ba)) \<longrightarrow> ((a, b) <' (aa, ba)) \<longrightarrow> False"
by auto

lemma Le6E [rule_format]:
"ALL a b aa ab ba bb.
((aa, ba) ==' (a, b)) & ~ ((a, b) <' (ab, bb)) \<longrightarrow> ((aa, ba) <' (ab, bb)) \<longrightarrow> False"
apply (auto)
apply(rule Le5)
apply(rule EqTOrdFSubstE)
apply(auto)
done

lemma Le7 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) <' (aa, ba) & ~ (a, b) <' (aa, ba) \<longrightarrow> False"
by auto

lemma Le8 [rule_format]:
"ALL a b aa ab ba bb.
(ab, bb) ==' (aa, ba) & (a, b) <' (aa, ba) \<longrightarrow> (a, b) <' (ab, bb)"
apply auto
apply(rule EqTOrdTSubstD)
apply(rule conjI)
by(auto)

lemma Le9 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) <' (aa, ba) & (aa, ba) ==' (ab, bb) \<longrightarrow> ~ (a, b) <' (ab, bb) \<longrightarrow> False"
apply auto
apply(rule Le8)
apply(auto)
apply (simp add: EqualSymDef)
done

lemma Le10 [rule_format]:
"ALL a b aa ab ba bb.
(aa, ba) <' (ab, bb) & (a, b) ==' (aa, ba) \<longrightarrow> ~ (a, b) <' (ab, bb) \<longrightarrow> False"
apply auto
apply(rule EqTOrdTSubstE)
apply(rule conjI)
by(auto)

lemma Le11 [rule_format]:
"ALL a b aa ab ba bb.
(ab, bb) <' (aa, ba) & (aa, ba) <' (a, b) \<longrightarrow> ~ (ab, bb) <' (a, b) \<longrightarrow> False"
apply(auto)
apply(rule LeTTransitive)
apply(auto)
done

lemma Le12 [rule_format]:
"ALL a b aa ab ba bb.
(aa, ba) <' (a, b) & (aa, ba) ==' (ab, bb) \<longrightarrow> ~ (ab, bb) <' (a, b) \<longrightarrow> False"
apply(auto)
apply(rule EqTOrdTSubstE)
apply(rule conjI)
apply(auto)
apply(simp add: EqualSymDef)
done

lemma Le13 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) <' (ab, bb) & (ab, bb) <' (aa, ba) \<longrightarrow> ~ (a, b) <' (aa, ba) \<longrightarrow> False"
apply(auto)
apply(rule LeTTransitive)
apply(rule conjI)
apply(auto)
done

lemma Le14 [rule_format]:
"ALL a b aa ab ba bb.
~ (a, b) <' (a, b)"
by(auto)

lemma Le15 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) <' (ab, bb) & (ab, bb) <' (aa, ba) \<longrightarrow> (a, b) <' (aa, ba) & (aa, ba) <' (a, b) \<longrightarrow> False"
apply(auto)
apply(simp add: LeTAsymmetry)
done

lemma Le16 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) ==' (aa, ba) & (ab, bb) <' (aa, ba) \<longrightarrow> (ab, bb) <' (a, b) & ~ (ab, bb) <' (a, b) \<longrightarrow> False"
by(auto)

lemma Le17 [rule_format]:
"ALL a b aa ab ba bb.
(ab, bb) <' (aa, ba) & (a, b) ==' (aa, ba) \<longrightarrow> (ab, bb) <' (a, b)"
apply(auto)
apply(rule EqTOrdTSubstD)
apply(rule conjI)
apply(auto)
done

lemma Le18 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) <' (ab, bb) & ~ (a, b) <' (ab, bb) \<longrightarrow> False"
by(auto)

lemma Le19 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) ==' (aa, ba) & (aa, ba) <' (ab, bb) \<longrightarrow> ~ (a, b) <' (ab, bb) \<longrightarrow> False"
apply(auto)
apply(rule EqTOrdTSubstE)
apply(auto)
done

lemma Le20 [rule_format]:
"ALL a b aa ab ba bb.
(a, b) ==' (aa, ba) & (ab, bb) <' (aa, ba) \<longrightarrow> ~ (ab, bb) <' (a, b) \<longrightarrow> False"
apply(auto)
apply(rule EqTOrdTSubstD)
apply(auto)
done

theorem LeqTTransitive :
"ALL x. ALL y. ALL z. (x <=' y) && (y <=' z) --> x <=' z"
apply(auto)
apply(simp add: LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
(*Here we needed the first aux lemma*)
apply(rule Le18)
apply(rule conjI)
apply(rule LeTTransitive)
apply(auto)
apply(case_tac "(aa, ba) ==' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(rule Le9)
apply(rule conjI)
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(rule Le19)
apply(auto)
apply(case_tac "(aa, ba) ==' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) <' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(rule EqualL2)
by(auto)

ML "Header.record \"LeqTTransitive\""

theorem LeqTTotal :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"
apply(auto)
apply(simp add: LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(simp add: LeTAsymmetry)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeqDef)
apply(simp add: OrDef)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef EqualL1)
done

ML "Header.record \"LeqTTotal\""

theorem GeqReflexivity : "ALL x. x >=' x"
apply(auto)
apply(simp add: GeqDef)
apply(simp add: OrDef)
apply(simp add: AndSym)
done

ML "Header.record \"GeqReflexivity\""

theorem GeqTTransitive :
"ALL x. ALL y. ALL z. (x >=' y) && (y >=' z) --> x >=' z"
apply(auto)
apply(simp add: GeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
(*Here we needed the first aux lemma*)
apply(simp add: GeDef)
apply(rule Le18)
apply(rule conjI)
apply(rule LeTTransitive)
apply(auto)
apply(case_tac "(aa, ba) ==' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(simp add: GeDef)
apply(rule Le10)
apply(rule conjI)
apply(simp add: EqualSymDef)+
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(simp add: GeDef)
apply(rule Le20)
apply(rule conjI)
apply(simp add: EqualSymDef)+
apply(case_tac "(aa, ba) ==' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) >' (ab, bb)")
apply(auto)
apply(case_tac "(a, b) ==' (ab, bb)")
apply(auto)
apply(rule EqualL2)
by(auto)

ML "Header.record \"GeqTTransitive\""

theorem GeqTTotal :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"
apply(auto)
apply(simp add: GeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeTAsymmetry)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef EqualL1)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef EqualL1)
done

ML "Header.record \"GeqTTotal\""

theorem LeTGeTRel : "ALL x. ALL y. x <' y = y >' x"
apply(auto)
apply(simp add: GeDef)+
done

ML "Header.record \"LeTGeTRel\""

theorem LeFGeFRel : "ALL x. ALL y. (~ x <' y) = (~ y >' x)"
apply(auto)
apply(simp add: GeDef)+
done

ML "Header.record \"LeFGeFRel\""

theorem LeqTGetTRel : "ALL x. ALL y. x <=' y = y >=' x"
apply(auto)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: GeDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef)
done

ML "Header.record \"LeqTGetTRel\""

theorem LeqFGetFRel : "ALL x. ALL y. (~ x <=' y) = (~ y >=' x)"
apply(auto)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(aa, ba) >' (a, b)")
apply(auto)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef)
done

ML "Header.record \"LeqFGetFRel\""

theorem GeTLeTRel : "ALL x. ALL y. x >' y = y <' x"
apply(auto)
apply(simp add: GeDef)+
done

ML "Header.record \"GeTLeTRel\""

theorem GeFLeFRel : "ALL x. ALL y. (~ x >' y) = (~ y <' x)"
apply(auto)
apply(simp add: GeDef)+
done

ML "Header.record \"GeFLeFRel\""

theorem GeqTLeqTRel : "ALL x. ALL y. x >=' y = y <=' x"
apply(auto)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef)
done

ML "Header.record \"GeqTLeqTRel\""

theorem GeqFLeqFRel : "ALL x. ALL y. (~ x >=' y) = (~ y <=' x)"
apply(auto)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(aa, ba) <' (a, b)")
apply(auto)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(case_tac "(aa, ba) ==' (a, b)")
apply(auto)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef)
done

ML "Header.record \"GeqFLeqFRel\""

theorem LeqTGeFRel : "ALL x. ALL y. x <=' y = (~ x >' y)"
apply(auto)
apply(simp add: GeqDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: EqualSymDef)
apply(simp add: GeDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeTAsymmetry)
apply(simp add: GeDef)
done

ML "Header.record \"LeqTGeFRel\""

theorem LeqFGeTRel : "ALL x. ALL y. (~ x <=' y) = x >' y"
apply(auto)
apply(simp add: GeDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(simp add: GeDef)
apply(simp add: GeDef LeqDef)
apply(simp add: OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(simp add: LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef LeTAsymmetry)
done

ML "Header.record \"LeqFGeTRel\""

theorem GeTLeFEqFRel :
"ALL x. ALL y. x >' y = (~ x <' y & ~ x ==' y)"
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(simp add: GeDef)
apply(simp add: EqualSymDef LeTAsymmetry)
apply(simp add: EqFSOrdRel)
done

ML "Header.record \"GeTLeFEqFRel\""

theorem GeFLeTEqTRel :
"ALL x. ALL y. (~ x >' y) = (x <' y | x ==' y)"
apply(auto)
apply(simp add: LeTGeFEqFRel)
apply(simp add: GeDef LeTAsymmetry)
apply(simp add: GeDef)
apply(simp add: EqualSymDef)
done

ML "Header.record \"GeFLeTEqTRel\""

theorem GeqTLeFRel : "ALL x. ALL y. x >=' y = (~ x <' y)"
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(simp add: GeDef LeTAsymmetry)
done

ML "Header.record \"GeqTLeFRel\""

theorem GeqFLeTRel : "ALL x. ALL y. (~ x >=' y) = x <' y"
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(simp add: GeDef LeTAsymmetry)
apply(rule disjE)
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
by(auto)

ML "Header.record \"GeqFLeTRel\""

theorem LeqTLeTEqTRel :
"ALL x. ALL y. x <=' y = (x <' y | x ==' y)"
apply(auto)
apply(simp add: LeqDef OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(simp add: LeqDef OrDef LeTAsymmetry)+
done

ML "Header.record \"LeqTLeTEqTRel\""

theorem LeqFLeFEqFRel :
"ALL x. ALL y. (~ x <=' y) = (~ x <' y & ~ x ==' y)"
apply(auto)
apply(simp add: LeqDef OrDef)+
done

ML "Header.record \"LeqFLeFEqFRel\""

theorem GeqTGeTEqTRel :
"ALL x. ALL y. x >=' y = (x >' y | x ==' y)"
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeqDef OrDef)+
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
done

ML "Header.record \"GeqTGeTEqTRel\""

theorem GeqFGeFEqFRel :
"ALL x. ALL y. (~ x >=' y) = (~ x >' y & ~ x ==' y)"
apply(auto)
apply(simp add: GeqDef OrDef)+
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeqDef OrDef)+
done

ML "Header.record \"GeqFGeFEqFRel\""

theorem LeTGeqFRel : "ALL x. ALL y. x <' y = (~ x >=' y)"
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(simp add: GeDef LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeqDef OrDef)
apply(case_tac "(a, b) >' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(simp add: GeDef LeTAsymmetry)
apply(rule disjE)
by(auto)

ML "Header.record \"LeTGeqFRel\""

theorem GeTLeqFRel : "ALL x. ALL y. x >' y = (~ x <=' y)"
apply(auto)
apply(simp add: GeDef LeqDef OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(simp add: LeTAsymmetry)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: EqualSymDef)
apply(simp add: LeqDef OrDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: GeDef)
apply(simp add: LeFGeTEqTRel)
apply(simp add: EqFSOrdRel)
apply(simp add: GeDef LeTAsymmetry)
done

ML "Header.record \"GeTLeqFRel\""

theorem LeLeqDiff : "ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"
apply(auto)
apply(simp add: LeqDef OrDef)
apply(simp add: DiffDef)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
apply(simp add: LeqDef OrDef)
apply(simp add: DiffDef)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
done

ML "Header.record \"LeLeqDiff\""

theorem MaxSym : "ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"
by (auto)

ML "Header.record \"MaxSym\""

theorem MinSym : "ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"
by (auto)

ML "Header.record \"MinSym\""

theorem TO1 : "ALL x. ALL y. (x ==' y | x <' y) = x <=' y"
apply(auto)
apply(simp add: LeqDef OrDef)+
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
done

ML "Header.record \"TO1\""

theorem TO2 : "ALL x. ALL y. x ==' y --> ~ x <' y"
by (auto)

ML "Header.record \"TO2\""

theorem TO3 : "ALL x. ALL y. Not' Not' (x <' y) | Not' (x <' y)"
by (auto)

ML "Header.record \"TO3\""

theorem TO4 : "ALL x. ALL y. x <' y --> Not' (x ==' y)"
apply(auto)
apply(case_tac "(a, b) ==' (aa, ba)")
apply(auto)
done

ML "Header.record \"TO4\""

theorem TO5 :
"ALL w. ALL x. ALL y. ALL z. (x <' y & y <' z) & z <' w --> x <' w"
apply(auto)
apply(rule_tac y="(ab, bb)" in LeTTransitive)
apply(auto)
apply(rule_tac y="(ac, bc)" in LeTTransitive)
by auto

ML "Header.record \"TO5\""

theorem TO6 : "ALL x. ALL z. z <' x --> Not' (x <' z)"
apply(auto)
apply(case_tac "(a, b) <' (aa, ba)")
apply(auto)
apply(simp add: LeTAsymmetry)
done

ML "Header.record \"TO6\""

theorem TO7 : "ALL x. ALL y. x <' y = y >' x"
apply(auto)
apply(simp add: GeDef)+
done

ML "Header.record \"TO7\""

theorem IUO01 : "makePartial () <=' makePartial ()"
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IUO01\""

theorem IUO02 : "~ makePartial () <' makePartial ()"
by (auto)

ML "Header.record \"IUO02\""

theorem IUO03 : "makePartial () >=' makePartial ()"
apply(simp add: GeqDef OrDef)
apply(case_tac "makePartial () >' makePartial ()")
apply(auto)
done

ML "Header.record \"IUO03\""

theorem IUO04 : "~ makePartial () >' makePartial ()"
apply(simp add: GeDef)
done

ML "Header.record \"IUO04\""

theorem IUO05 :
"X_max (makePartial ()) (makePartial ()) ==' makePartial ()"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IUO05\""

theorem IUO06 :
"X_min (makePartial ()) (makePartial ()) ==' makePartial ()"
apply(simp add: MinXDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IUO06\""

theorem IUO07 :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"
by (auto)

ML "Header.record \"IUO07\""

theorem IOO16 : "makePartial LT <=' makePartial EQ"
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO16\""

theorem IOO17 : "makePartial EQ <=' makePartial GT"
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO17\""

theorem IOO18 : "makePartial LT <=' makePartial GT"
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO18\""

theorem IOO19 : "makePartial EQ >=' makePartial LT"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IOO19\""

theorem IOO20 : "makePartial GT >=' makePartial EQ"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IOO20\""

theorem IOO21 : "makePartial GT >=' makePartial LT"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IOO21\""

theorem IOO22 : "makePartial EQ >' makePartial LT"
apply(simp add: GeDef OrDef)
done

ML "Header.record \"IOO22\""

theorem IOO23 : "makePartial GT >' makePartial EQ"
apply(simp add: GeDef OrDef)
done

ML "Header.record \"IOO23\""

theorem IOO24 : "makePartial GT >' makePartial LT"
apply(simp add: GeDef OrDef)
done

ML "Header.record \"IOO24\""

theorem IOO25 :
"X_max (makePartial LT) (makePartial EQ) ==' makePartial EQ"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO25\""

theorem IOO26 :
"X_max (makePartial EQ) (makePartial GT) ==' makePartial GT"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO26\""

theorem IOO27 :
"X_max (makePartial LT) (makePartial GT) ==' makePartial GT"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO27\""

theorem IOO28 :
"X_min (makePartial LT) (makePartial EQ) ==' makePartial LT"
apply(simp add: MinXDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO28\""

theorem IOO29 :
"X_min (makePartial EQ) (makePartial GT) ==' makePartial EQ"
apply(simp add: MinXDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO29\""

theorem IOO30 :
"X_min (makePartial LT) (makePartial GT) ==' makePartial LT"
apply(simp add: MinXDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IOO30\""

theorem IOO31 :
"compare (makePartial LT) (makePartial LT) ==' makePartial EQ"
by (auto)

ML "Header.record \"IOO31\""

theorem IOO32 :
"compare (makePartial EQ) (makePartial EQ) ==' makePartial EQ"
by (auto)

ML "Header.record \"IOO32\""

theorem IOO33 :
"compare (makePartial GT) (makePartial GT) ==' makePartial EQ"
by (auto)

ML "Header.record \"IOO33\""

theorem IBO6 : "~ undefinedOp >=' makePartial ()"
apply(simp add: GeqDef OrDef GeDef)
apply (case_tac "makePartial () <' undefinedOp")
apply(auto)
apply(simp add: LeTGeFEqFRel)
apply(simp add: GeDef)
done

ML "Header.record \"IBO6\""

theorem IBO7 : "makePartial () >=' undefinedOp"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IBO7\""

theorem IBO8 : "~ makePartial () <' undefinedOp"
apply(simp add: LeFGeTEqTRel)
apply(simp add: GeDef)
done

ML "Header.record \"IBO8\""

theorem IBO9 :
"X_max undefinedOp (makePartial ()) ==' makePartial ()"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IBO9\""

theorem IBO10 :
"X_min undefinedOp (makePartial ()) ==' undefinedOp"
apply(simp add: MaxYDef)
apply(simp add: LeqDef OrDef)
done

ML "Header.record \"IBO10\""

theorem IBO11 :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"
by (auto)

ML "Header.record \"IBO11\""

theorem IBO12 :
"compare undefinedOp undefinedOp ==' makePartial EQ"
by (auto)

ML "Header.record \"IBO12\""

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_propositional_Sound
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun z :: "'a list => 'a list => 'a list" where
  "z (nil2) y2 = y2"
| "z (cons2 z2 xs) y2 = cons2 z2 (z xs y2)"

fun y :: "int => ((int, bool) pair) list => bool list" where
  "y x2 (nil2) = nil2"
| "y x2 (cons2 (pair2 y22 True) x22) = cons2 (x2 = y22) (y x2 x22)"
| "y x2 (cons2 (pair2 y22 False) x22) = y x2 x22"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 x2 (nil2) = nil2"
| "models7 x2 (cons2 z2 xs) =
     (if (x2 ~= (case z2 of pair2 x22 y22 => x22)) then
        cons2 z2 (models7 x2 xs)
        else
        models7 x2 xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 x2 (nil2) = nil2"
| "models6 x2 (cons2 (pair2 y22 True) x22) = models6 x2 x22"
| "models6 x2 (cons2 (pair2 y22 False) x22) =
     cons2 (x2 = y22) (models6 x2 x22)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 x2 (nil2) = nil2"
| "models5 x2 (cons2 z2 xs) =
     (if (x2 ~= (case z2 of pair2 x22 y22 => x22)) then
        cons2 z2 (models5 x2 xs)
        else
        models5 x2 xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 x2 (nil2) = nil2"
| "models4 x2 (cons2 (pair2 y22 True) x22) =
     cons2 (x2 = y22) (models4 x2 x22)"
| "models4 x2 (cons2 (pair2 y22 False) x22) = models4 x2 x22"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models x2 q (nil2) = models2 q x2"
| "models x2 q (cons2 z2 x22) = cons2 z2 (models x2 q x22)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     z (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x22)) y2 =
     (if (~ (or2 (models4 x22 y2))) then
        cons2 (cons2 (pair2 x22 False) (models5 x22 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun t2 :: "((int, bool) pair) list => Form => bool" where
  "t2 x2 (x p q) = ((t2 x2 p) & (t2 x2 q))"
| "t2 x2 (Not r) = (~ (t2 x2 r))"
| "t2 x2 (Var z2) = or2 (y z2 x2)"

fun formula :: "Form => (((int, bool) pair) list) list =>
              bool" where
  "formula p (nil2) = True"
| "formula p (cons2 y2 xs) = ((t2 y2 p) & (formula p xs))"

theorem property0 :
  "formula p (models3 p (nil2))"
  oops

end