(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Tree relabelling\<close>

theory Tree_Relabelling imports
  Applicative_State
  Applicative_Option
  "~~/src/HOL/Library/Stream"
begin

interpretation applicative_syntax .
adhoc_overloading Applicative.pure pure_state
adhoc_overloading Applicative.pure pure_option

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) (op +)"

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 :: "('x, 's) state"
begin

definition label_tree :: "'a tree \<Rightarrow> ('x tree, 's) 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> ('x list, 's) state"
where
    "label_list [] = pure []"
  | "label_list (x # xs) = pure (op #) \<diamondop> fresh \<diamondop> label_list xs"

lemma label_append: "label_list (a @ b) = pure (op @) \<diamondop> label_list a \<diamondop> label_list b"
  -- \<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 (label_list xs s))"
  shows "distinct (labels (fst (label_tree t s)))"
using label_tree_list[of t, THEN fun_cong, of s] assms[of "labels t"]
by(cases "label_list (labels t) s")(simp add: ap_state_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 ('a, 's) state_rev = "('a, 's) state dual"

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

definition ap_state_rev :: "('a \<Rightarrow> 'b, 's) state_rev \<Rightarrow> ('a, 's) state_rev \<Rightarrow> ('b, 's) state_rev"
where "ap_state_rev = ap_dual pure_state ap_state ap_state"

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 ('a, 's) state_rev_rev = "('a, 's) state_rev dual"

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

definition ap_state_rev_rev :: "('a \<Rightarrow> 'b, 's) state_rev_rev \<Rightarrow> ('a, 's) state_rev_rev \<Rightarrow> ('b, 's) 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)+

context begin interpretation applicative_syntax .
lemma ap_state_rev_B: "B f \<diamondop> B x = B (pure_state (\<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 (pure_state 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)
end

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>
definition bind_state :: "('s \<Rightarrow> 'a \<times> 's) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'b \<times> 's) \<Rightarrow> 's \<Rightarrow> 'b \<times> 's"
where "bind_state x f s = (let (a, s') = x s in f a s')"

lemma bind_state_assoc: "bind_state (bind_state x f) g = bind_state x (\<lambda>x. bind_state (f x) g)"
by(simp add: fun_eq_iff bind_state_def split_def Let_def)

lemma bind_state_return1: "bind_state (Pair x) f = f x"
by(simp add: bind_state_def fun_eq_iff)

lemma ap_conv_bind_state: "ap_state f x = bind_state f (\<lambda>f. bind_state x (Pair \<circ> f))"
by(simp add: ap_state_def bind_state_def Let_def split_def o_def fun_eq_iff)

lemma ap_pure_bind_state: "pure x \<diamondop> bind_state y f = bind_state y (op \<diamondop> (pure x) \<circ> f)"
by(simp add: ap_conv_bind_state bind_state_return1 bind_state_assoc o_def)

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

definition fetch :: "('a, 'a stream) state"
where "fetch s = (shd s, stl s)"

primrec traverse :: "('a \<Rightarrow> ('b, 's) state) \<Rightarrow> 'a tree \<Rightarrow> ('b tree, 's) 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> ('b, 's) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('b tree, 's) 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> ('b, 's) state) \<Rightarrow> 'a tree \<Rightarrow> ('b tree, 's) 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"
    -- \<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 (pure_state 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" -- \<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> ('b, 's) state_rev_rev) \<Rightarrow> 'a tree \<Rightarrow> ('b tree, 's) 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> ('b, 's) state_rev) \<Rightarrow> 'a tree \<Rightarrow> ('b tree, 's) 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"
-- \<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. bind_state (g x) f = Pair x" by(simp add: fun_eq_iff)
  hence **: "\<And>x h. bind_state (g x) (\<lambda>x. bind_state (f x) h) = h x"
    by(fold bind_state_assoc)(simp add: bind_state_return1)
  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 bind_state_assoc bind_state_return1 recurse_Leaf **)
  next
    case (Node l r)
    show ?case
      by(simp add: ap_conv_bind_state bind_state_assoc bind_state_return1 recurse_Node)
        (simp add: bind_state_assoc[symmetric] Node.IH bind_state_return1)
  qed
qed

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

definition strip :: "'a \<times> 'b \<Rightarrow> ('a, 'b stream) state"
where "strip = (\<lambda>(a, b) s. (a, SCons b s))"

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

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

abbreviation unlabel :: "('a \<times> 'b) tree \<Rightarrow> ('a tree, 'b stream) 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] bind_state_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> ('x, 's) state \<Rightarrow> ('x list, 's) state"
where
  "repeatM 0 f = pure_state []"
| "repeatM (Suc n) f = pure op # \<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 :: "('a, 's) state \<Rightarrow> ('a option, 's) state"
where [applicative_unfold]: "lift_state x = pure pure \<diamondop> x"

definition lift_option :: "'a option \<Rightarrow> ('a option, 's) 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> ('x list option, 's) 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 "pure_state 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 "pure_state 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

end


(* Title: Verification Component Based on Divergence Kleene Algebra for Total Correctness: Examples
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection\<open>Verification Examples\<close>

theory VC_KAD_wf_Examples
  imports VC_KAD_wf
begin

text \<open>The example should be taken with a grain of salt. More work is needed to make
the while rule cooperate with simplification.\<close>

lemma euclid:
  "rel_nabla (
    \<lceil>\<lambda>s::nat store. 0 < s ''y''\<rceil> ;
      ((''z'' ::= (\<lambda>s. s ''y'')) ;
      (''y'' ::= (\<lambda>s. s ''x'' mod s ''y'')) ;
      (''x'' ::= (\<lambda>s. s ''z''))))
    = {}
    \<Longrightarrow>
  PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (subst rel_fdivka.fbox_arden_whilei[symmetric], simp_all)
  using gcd_red_nat gr0I by force

text \<open>The termination assumption is now explicit in the verification proof. Here it is left
untouched. Means beyond these components are required for discharging it.\<close>

end


theory StateTransformers
  imports "../Algebra/PartialQuantales"
begin

no_notation plus (infixl "+" 65)
no_notation pmult (infixl "*" 80)
no_notation pmult_one ("1")
notation pmult (infixl "\<oplus>" 80)
notation times (infixl "*" 70)
notation sup (infixl "+" 65)
notation inf (infixl "\<sqinter>" 70)
notation one_class.one ("1")

text{*
  State transformers are functions from state to predicates, abstractly, from commutative
  partial monoid to quantales
*}

text {*
  If the domain is a partial semigroup and the image is a quantale, it forms a quantale
*}

instantiation "fun" :: (partial_semigroup, quantale) quantale
begin

definition "f * g \<equiv> \<lambda>x. \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}"

lemma qmult_apply [simp, code]:
  "(f * g) x \<equiv> \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}"
  by (simp add: times_fun_def)

lemma sup_distrib_left_fun: "(f * (g + h)) x = (f * g + f * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistl) simp

lemma sup_distrib_right_fun: "((f + g) * h) x = (f * h + g * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistr) simp

lemma qSup_distl_fun: "(f * \<Squnion>G) x = (\<Squnion>(op * f ` G)) x"
  apply (auto simp add: qSUP_distl intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma qSup_distr_fun: "(\<Squnion>G * f) x = (\<Squnion>((\<lambda>g. g * f) ` G)) x"
  apply (auto simp add: qSUP_distr intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma Sup_distl_assoc: "(f :: 'a \<Rightarrow> 'b) y * \<Squnion>{g y' * h z' |y' z' :: 'a. z = y' \<oplus> z' \<and> y' ## z'} = \<Squnion>{f y * (g y' * h z') |y' z'. z = y' \<oplus> z' \<and> y' ## z'}"
  by (auto simp only: Sup.Join_distl intro: Sup.Join_eqI2)

lemma qSup_distr_assoc: "\<Squnion>{((f :: 'a \<Rightarrow> 'b) y * g y') | y y' :: 'a. z = (y \<oplus> y') \<and> y ## y'} * h z' = \<Squnion>{(f y * g y') * h z' | y y'. z = (y \<oplus> y') \<and> y ## y'}"
  by (auto simp only: qSup_distr intro: Sup.Join_eqI2)

lemma qmult_assoc_fun: "(f * (g * h)) x = ((f * g) * h) x"
proof -
  have "(f * (g * h)) x = \<Squnion> {\<Squnion> {(f y * g y') * h z' | y' z'. z = y' \<oplus> z' \<and> y' ## z'} | y z. x = y \<oplus> z \<and> y ## z}"
    by (simp add: Sup_distl_assoc mult.assoc)
  also have "... = \<Squnion> {(f y * g y') * h z' | y' z' y z. z = y' \<oplus> z' \<and> y' ## z' \<and> x = y \<oplus> z \<and> y ## z}"
    apply (rule antisym, rule Sup_least, safe, rule Sup_mono, auto, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>ya z. y \<oplus> (y' \<oplus> z') = ya \<oplus> z \<and> ya ## z \<and> f y * g y' * h z' \<le> \<Squnion>{f ya * g y' * h z' |y' z'. z = y' \<oplus> z' \<and> y' ## z'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    by (smt Sup_le_iff dual_order.refl mem_Collect_eq)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. y' ## z' \<and> x = y \<oplus> (y' \<oplus> z') \<and> y ## (y' \<oplus> z')}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. y ## y' \<and> x = (y \<oplus> y') \<oplus> z' \<and> (y \<oplus> y') ## z'}"
    by (metis (hide_lams, no_types) partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y' z. z = (y \<oplus> y') \<and> y ## y' \<and> x = z \<oplus> z' \<and> z ## z'}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion>{ \<Squnion>{(f y * g y') * h z' | y y'. z = (y \<oplus> y') \<and> y ## y'} | z z'. x = z \<oplus> z' \<and> z ## z'}"
    apply (rule antisym, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>z z'a. y \<oplus> y' \<oplus> z' = z \<oplus> z'a \<and> z ## z'a \<and> f y * g y' * h z' \<le> \<Squnion>{f y * g y' * h z'a |y y'. z = y \<oplus> y' \<and> y ## y'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    apply (smt Sup_le_iff dual_order.refl mem_Collect_eq)
    by (rule Sup_least, safe, rule Sup_mono, auto)
  finally show ?thesis
    by (simp add: qSup_distr_assoc)
qed

instance
  apply default
  apply (rule ext, rule qmult_assoc_fun[symmetric])
  apply (rule ext, rule qSup_distr_fun)
  by (metis (lifting, mono_tags) qSup_distl_fun eq_iff le_funI)+

end

text {* Unit is also lifted *}

instantiation "fun" :: (partial_monoid, quantale_unital) quantale_unital
begin

definition
  "1 \<equiv> \<lambda>x. if x = 1' then 1 else \<bottom>"

lemma qunitl_fun[simp]: "(1 * f) x = f x"
  by (auto simp: pmult_onel one_fun_def intro!: Sup_eqI)

lemma qunitr_fun[simp]: "(f * 1) x = f x"
  by (auto simp: pmult_oner one_fun_def intro!: Sup_eqI)

instance
  by default  (auto intro: qunitr_fun qunitl_fun)

end

text {* Commutativity is also lifted *}

instance "fun" :: (partial_ab_semigroup, comm_quantale) comm_quantale
proof (default, simp_all add: mult.assoc, rule ext)
  fix f g :: "'a :: partial_ab_semigroup \<Rightarrow> 'b :: comm_quantale"
  fix x :: "'a :: partial_ab_semigroup"
  have "(f * g) x = \<Squnion> {f y * g z | y z. x = y \<oplus> z \<and> y ## z}" by simp
  also have "... = \<Squnion> {g z * f y | z y. x = z \<oplus> y \<and> z ## y}"
    apply (auto intro!: Sup.Join_eqI2)
    by (metis mult.commute pmult_comm pmult_comm_def)+
  finally show "(f * g) x = (g * f) x" by simp
qed

instance "fun" :: (partial_comm_monoid, comm_quantale_unital) comm_quantale_unital
  by default auto

text {* Distributivity is also lifted *}

instance "fun" :: (partial_semigroup, distrib_quantale) distrib_quantale ..

instance "fun" :: (partial_comm_monoid, distrib_comm_quantale_unital) distrib_comm_quantale_unital ..

end


theory FinFun_Supplemental
imports "~~/src/HOL/Library/FinFun"
begin

unbundle finfun_syntax

context includes lifting_syntax
begin

lemma finfun_Diag_transfer[transfer_rule]:
  "((pcr_finfun A B) ===> (pcr_finfun A C) ===> (pcr_finfun A (rel_prod B C)))
    (\<lambda> f g  x . (f x, g x)) (\<lambda> ff gg . ($ ff, gg $))"
  unfolding  OO_def pcr_finfun_def cr_finfun_def rel_prod_conv rel_fun_def
  by auto

lemma finfun_comp_transfer[transfer_rule]:
  shows "((B ===> C) ===> (pcr_finfun A B) ===> (pcr_finfun A C))
    (\<lambda> f1 g . f1 o g) (\<lambda> f2 gg . f2 o$ gg)"
  unfolding  OO_def pcr_finfun_def cr_finfun_def rel_prod_conv rel_fun_def by auto

end

lemma finfun_default_determined:
  fixes f::"'c \<Rightarrow> 'd" and  b B
  defines "B \<equiv> {a. f a \<noteq> b}"
  assumes infin: "\<not> finite (UNIV :: 'c set)" and fin:"finite B"
  shows "(THE b. finite {a. f a \<noteq> b}) = b"
proof -
  from fin show ?thesis unfolding B_def
  proof(elim the_equality)
    fix b'
    assume "finite {a. f a \<noteq> b'}" (is "finite ?B'")
    with infin fin have "UNIV - (?B' \<union> B) \<noteq> {}" using finite_subset by auto
    then obtain a where a: "a \<notin> ?B' \<union> B" by auto
    thus "b' = b" by (auto simp add:B_def)
  qed
qed

lemma comp_default:
  fixes ff :: "'c \<Rightarrow>f 'd" and f
  assumes infin:"infinite (UNIV::'c set)"
  shows "finfun_default (f o$ ff) = f (finfun_default ff)"
  apply transfer apply (simp add:finfun_default_aux_def finfun_def)
  subgoal premises prems for f ff
  proof -
    from \<open>\<exists>b. finite {a. ff a \<noteq> b}\<close> obtain b where "finite {a. ff a \<noteq> b}"
      by auto
    hence 1:"(THE b. finite {a. ff a \<noteq> b}) = b" using infin by (auto simp add: finfun_default_determined)
    let ?b' = "f b"
    have "finite {a. f (ff a) \<noteq> ?b'}" using \<open>finite {a. ff a \<noteq> b}\<close>
      by (metis (mono_tags, lifting) Collect_mono finite_subset)
    hence 2:"(THE b. finite {a. f (ff a) \<noteq> b}) = ?b'" using infin by (auto simp add: finfun_default_determined)
    from 1 2 infin show ?thesis by blast
  qed
  done

lemma diag_default:
  assumes "finfun_default (ff1::'c \<Rightarrow>f 'd) = d1"
  and "finfun_default (ff2::'c \<Rightarrow>f 'e) = d2"
  and infin:"infinite (UNIV::'c set)"
  shows "finfun_default ($ ff1, ff2 $) = (d1,d2)" using assms
  apply (transfer)
  apply (auto simp add:finfun_default_aux_def finfun_def)
  subgoal premises prems for f1 f2 b1 b2
  proof -
    thm prems
    from \<open>finite {a. f1 a \<noteq> b1}\<close> and \<open>finite {a. f2 a \<noteq> b2}\<close>
    have 1:"(THE b . finite {a. f1 a \<noteq> b}) = b1" and 2:"(THE b . finite {a. f2 a \<noteq> b}) = b2"
      using infin
      by (auto simp add: finfun_default_determined)
    let ?b = "(b1,b2)"
    have "finite {a. (f1 a, f2 a) \<noteq> ?b}" (is "finite ?S")
    proof -
      have "?S = {a. f1 a \<noteq> b1} \<union> {a. f2 a \<noteq> b2}" by blast
      thus ?thesis using \<open>finite {a. f1 a \<noteq> b1}\<close> and \<open>finite {a. f2 a \<noteq> b2}\<close> by simp
    qed
    thus ?thesis using 1 2 infin by (auto simp add:finfun_default_determined)
  qed
  done

text {* Why not do this with @{term finfun_rec}? *}
lift_definition my_comp :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow>f 'b) \<Rightarrow> ('a \<Rightarrow>f 'c option)"
  is "\<lambda> f ff . \<lambda> x . if finfun_dom ff $ x then Some (f x (ff $ x)) else None"
  apply (auto simp add:finfun_def)
  by (smt Abs_finfun_inverse Collect_cong finfun_dom_def finfun_dom_finfunI finite_finfun_default option.distinct(1))

lemma my_comp_default[simp]:
  assumes "\<not> finite (UNIV::'c set)"
  fixes f::"'c \<Rightarrow> 'd \<Rightarrow> 'b" and ff::"'c \<Rightarrow>f 'd"
  shows "finfun_default (my_comp f ff) = None"
proof (transfer)
  fix f::"'c \<Rightarrow> 'd \<Rightarrow> 'b" and ff :: "'c \<Rightarrow>f 'd"
  let ?comp = "\<lambda>x. if finfun_dom ff $ x then Some (f x (ff $ x)) else None"
  have "finite {x . ?comp x \<noteq> None}"
    using finite_finfun_dom by fastforce
  hence "(THE b . finite {x . ?comp x \<noteq> b}) = None" using finfun_default_determined[OF assms,
        where ?b=None and ?f="?comp"] by auto
  thus "finfun_default_aux (\<lambda>x. if finfun_dom ff $ x then Some (f x (ff $ x)) else None) = None"
    using assms by (simp add:finfun_default_aux_def)
qed

lemma my_comp_dom[simp]:
  assumes "\<not> finite (UNIV::'c set)"
  fixes f::"'c \<Rightarrow> 'd \<Rightarrow> 'b" and ff::"'c \<Rightarrow>f 'd"
  shows "finfun_dom (my_comp f ff) = finfun_dom ff" using my_comp_default[OF assms, of f ff]
  apply (auto simp add:finfun_dom_def my_comp_def)
proof -
  { fix cc :: 'c and bb :: 'b
    { assume "\<exists>f. my_comp f ff $ cc \<noteq> (None::'b option)"
      then have "\<exists>fa c fb. ff $ cc \<noteq> finfun_default ff \<and> fa $ (c::'c) \<noteq> (finfun_default fa::'d) \<and> my_comp f ff $ cc = my_comp fb fa $ c"
        by (metis finfun_dom_conv my_comp.rep_eq) }
    then have "Abs_finfun (\<lambda>c. \<exists>b. Abs_finfun (\<lambda>c. if Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff) $ c then Some (id f c (id ff $ c)) else None) $ c = Some b) = Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff) \<or> (\<exists>b. Abs_finfun (\<lambda>c. if Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff) $ c then Some (id f c (id ff $ c)) else None) $ cc = Some b) \<and> ff $ cc \<noteq> finfun_default ff \<or> ff $ cc = finfun_default ff \<and> Abs_finfun (\<lambda>c. if Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff) $ c then Some (id f c (id ff $ c)) else None) $ cc \<noteq> Some bb"
      by (metis (no_types) finfun_dom_conv finfun_dom_def id_apply my_comp.abs_eq my_comp.rep_eq option.distinct(1)) }
  then show "Abs_finfun (\<lambda>c. \<exists>b. Abs_finfun (\<lambda>c. if Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff) $ c then Some (id f c (id ff $ c)) else None) $ c = Some b) = Abs_finfun (\<lambda>c. ff $ c \<noteq> finfun_default ff)"
    by meson
qed

lift_definition finfun_dom_2 :: "('a \<Rightarrow>f 'b) \<Rightarrow> ('a \<Rightarrow>f bool)"
  is "\<lambda> ff . \<lambda> a . ff $ a \<noteq> finfun_default ff"
  using FinFun.finfun_dom_finfunI by assumption

declare finfun_default_const_code[simp]

end


theory EnumType
  imports
    Main
    "Ecore-GROOVE-Mapping.Type_Model_Graph_Mapping"
    "Ecore-GROOVE-Mapping.Identifier_List"
begin

section "Definition of a type model which introduces a Class"

definition tmod_enum :: "'t Id \<Rightarrow> 't set \<Rightarrow> 't type_model" where
  "tmod_enum name values = \<lparr>
    Class = {},
    Enum = {name},
    UserDataType = {},
    Field = {},
    FieldSig = (\<lambda>x. undefined),
    EnumValue = Pair name ` values,
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tmod_enum_correct: "type_model (tmod_enum name values)"
proof (intro type_model.intro)
  fix ev
  assume "ev \<in> EnumValue (tmod_enum name values)"
  then have "fst ev = name"
    unfolding tmod_enum_def
    by fastforce
  then show "fst ev \<in> Enum (tmod_enum name values)"
    unfolding tmod_enum_def
    by simp
next
  have "asym {} \<and> irrefl {}"
    by (simp add: asym.intros irrefl_def)
  then show "asym (Inh (tmod_enum name values)) \<and> irrefl ((Inh (tmod_enum name values))\<^sup>+)"
    unfolding tmod_enum_def
    by simp
qed (simp_all add: tmod_enum_def)

lemma tmod_enum_combine_correct:
  assumes "type_model Tmod"
  assumes new_enum: "name \<notin> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
  assumes "\<And>x. x \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod \<Longrightarrow> \<not>id_in_ns name (Identifier x) \<and> \<not>id_in_ns x (Identifier name)"
  shows "type_model (tmod_combine Tmod (tmod_enum name values))"
proof (intro tmod_combine_full_distinct_correct)
  show "type_model (tmod_enum name values)"
    by (fact tmod_enum_correct)
next
  show "(Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod) \<inter> (Class (tmod_enum name values) \<union> Enum (tmod_enum name values) \<union> UserDataType (tmod_enum name values)) = {}"
    unfolding tmod_enum_def
    using new_enum
    by simp
qed (simp_all add: assms tmod_enum_def)

section "Encoding of a Enum as Node Types in GROOVE"

definition tg_enum_as_node_types :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t list) type_graph" where
  "tg_enum_as_node_types name values = \<lparr>
    NT = {type (id_to_list name)} \<union> type ` append (id_to_list name) ` (\<lambda>x. [x]) ` values,
    ET = {},
    inh = {(type (id_to_list name), type (id_to_list name))} \<union>
      (\<lambda>x. (type x, type x)) ` append (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
      (\<lambda>x. (type x, type (id_to_list name))) ` append (id_to_list name) ` (\<lambda>x. [x]) ` values,
    abs = {type (id_to_list name)},
    mult = (\<lambda>x. undefined),
    contains = {}
  \<rparr>"

lemma tg_enum_as_node_types_correct: "type_graph (tg_enum_as_node_types name values)"
proof (intro type_graph.intro)
  fix n
  assume "n \<in> NT (tg_enum_as_node_types name values)"
  then have "n \<in> Lab\<^sub>t"
    unfolding tg_enum_as_node_types_def
    using Lab\<^sub>t.simps
    by fastforce
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    by blast
next
  show inheritance_field: "Relation.Field (inh (tg_enum_as_node_types name values)) = NT (tg_enum_as_node_types name values)"
  proof
    show "Relation.Field (inh (tg_enum_as_node_types name values)) \<subseteq> NT (tg_enum_as_node_types name values)"
    proof
      fix x
      assume "x \<in> Relation.Field (inh (tg_enum_as_node_types name values))"
      then show "x \<in> NT (tg_enum_as_node_types name values)"
        unfolding Relation.Field_def
      proof (elim UnE)
        assume "x \<in> Domain (inh (tg_enum_as_node_types name values))"
        then show "x \<in> NT (tg_enum_as_node_types name values)"
        proof
          fix b
          assume "(x, b) \<in> inh (tg_enum_as_node_types name values)"
          then show "x \<in> NT (tg_enum_as_node_types name values)"
            unfolding tg_enum_as_node_types_def
            by fastforce
        qed
      next
        assume "x \<in> Range (inh (tg_enum_as_node_types name values))"
        then show "x \<in> NT (tg_enum_as_node_types name values)"
        proof
          fix a
          assume "(a, x) \<in> inh (tg_enum_as_node_types name values)"
          then show "x \<in> NT (tg_enum_as_node_types name values)"
            unfolding tg_enum_as_node_types_def
            by fastforce
        qed
      qed
    qed
  next
    show "NT (tg_enum_as_node_types name values) \<subseteq> Relation.Field (inh (tg_enum_as_node_types name values))"
    proof
      fix x
      assume "x \<in> NT (tg_enum_as_node_types name values)"
      then have "x \<in> {type (id_to_list name)} \<union> type ` append (id_to_list name) ` (\<lambda>x. [x]) ` values"
        unfolding tg_enum_as_node_types_def
        by simp
      then show "x \<in> Relation.Field (inh (tg_enum_as_node_types name values))"
      proof (elim UnE)
        assume "x \<in> {type (id_to_list name)}"
        then show "x \<in> Relation.Field (inh (tg_enum_as_node_types name values))"
          unfolding tg_enum_as_node_types_def
          by simp
      next
        assume "x \<in> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        then show "x \<in> Relation.Field (inh (tg_enum_as_node_types name values))"
          unfolding Relation.Field_def tg_enum_as_node_types_def
          by fastforce
      qed
    qed
  qed
  show "Partial_order (inh (tg_enum_as_node_types name values))"
    unfolding partial_order_on_def preorder_on_def
  proof (intro conjI)
    show "Refl (inh (tg_enum_as_node_types name values))"
      unfolding refl_on_def
    proof (intro conjI)
      show "inh (tg_enum_as_node_types name values) \<subseteq> Relation.Field (inh (tg_enum_as_node_types name values)) \<times> Relation.Field (inh (tg_enum_as_node_types name values))"
        using FieldI1 FieldI2 inheritance_field
        by fastforce
    next
      have "\<And>x. x \<in> NT (tg_enum_as_node_types name values) \<Longrightarrow> (x, x) \<in> inh (tg_enum_as_node_types name values)"
        unfolding tg_enum_as_node_types_def
        by fastforce
      then show "\<forall>x \<in> Relation.Field (inh (tg_enum_as_node_types name values)). (x, x) \<in> inh (tg_enum_as_node_types name values)"
        using inheritance_field
        by blast
    qed
  next
    show "trans (inh (tg_enum_as_node_types name values))"
      unfolding tg_enum_as_node_types_def trans_def
      by fastforce
  next
    show "antisym (inh (tg_enum_as_node_types name values))"
      unfolding tg_enum_as_node_types_def antisym_def
      by fastforce
  qed
qed (simp_all add: tg_enum_as_node_types_def)

lemma tg_enum_as_node_types_combine_correct:
  assumes "type_graph TG"
  assumes new_enum_type: "type (id_to_list name) \<notin> NT TG"
  assumes new_value_types: "NT TG \<inter> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values = {}"
  shows "type_graph (tg_combine TG (tg_enum_as_node_types name values))"
proof (intro tg_combine_distinct_correct)
  show "type_graph (tg_enum_as_node_types name values)"
    by (fact tg_enum_as_node_types_correct)
qed (simp_all add: tg_enum_as_node_types_def assms)

subsection "Transformation functions"

definition tmod_enum_to_tg_enum_as_node_types :: "'t type_model \<Rightarrow> ('t list) type_graph" where
  "tmod_enum_to_tg_enum_as_node_types Tmod = \<lparr>
    NT = type ` id_to_list ` Enum Tmod \<union> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue Tmod,
    ET = {},
    inh = type ` id_to_list ` Enum Tmod \<times> type ` id_to_list ` Enum Tmod \<union>
      (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue Tmod \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue Tmod \<times> type ` id_to_list ` Enum Tmod,
    abs = type ` id_to_list ` Enum Tmod,
    mult = (\<lambda>x. undefined),
    contains = {}
  \<rparr>"

lemma tmod_enum_to_tg_enum_as_node_types_proj:
  shows "tmod_enum_to_tg_enum_as_node_types (tmod_enum name values) = tg_enum_as_node_types name values"
proof-
  have nt_proj: "type ` id_to_list ` Enum (tmod_enum name values) \<union>
    type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) =
    {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
  proof
    show "type ` id_to_list ` Enum (tmod_enum name values) \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<subseteq>
      {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
    proof
      fix x
      assume "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<union>
        type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values)"
      then show "x \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
      proof (elim UnE)
        assume "x \<in> type ` id_to_list ` Enum (tmod_enum name values)"
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      next
        assume "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values)"
        then show ?thesis
          unfolding tmod_enum_def
          by fastforce
      qed
    qed
  next
    show "{type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<subseteq>
      type ` id_to_list ` Enum (tmod_enum name values) \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values)"
    proof
      fix x
      assume "x \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
      then show "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<union>
        type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values)"
      proof (elim UnE)
        assume "x \<in> {type (id_to_list name)}"
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      next
        assume "x \<in> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        then have "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
        proof (elim imageE)
          fix a b c
          assume c_def: "c \<in> values"
          assume b_def: "b = [c]"
          assume "a = id_to_list name @ b"
          then have a_def: "a = id_to_list name @ [c]"
            by (simp add: b_def)
          assume "x = type a"
          then have x_def: "x = type (id_to_list name @ [c])"
            by (simp add: a_def)
          then show ?thesis
          proof
            show "id_to_list name @ [c] \<in> (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
              by (simp add: c_def image_iff)
          qed
        qed
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      qed
    qed
  qed
  have inh_proj: "type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<union>
    (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<union>
    type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) =
    {(type (id_to_list name), type (id_to_list name))} \<union> (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
    (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
  proof
    show "type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<union>
      (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<subseteq>
      {(type (id_to_list name), type (id_to_list name))} \<union> (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
      (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
    proof
      fix x
      assume "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<union>
        (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<union>
        type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values)"
      then show "x \<in> {(type (id_to_list name), type (id_to_list name))} \<union>
        (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
        (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
      proof (elim UnE)
        assume "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values)"
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      next
        assume "x \<in> (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values)"
        then show ?thesis
          unfolding tmod_enum_def
          by fastforce
      next
        assume "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values)"
        then show ?thesis
          unfolding tmod_enum_def
          by fastforce
      qed
    qed
  next
    show "{(type (id_to_list name), type (id_to_list name))} \<union> (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
      (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<subseteq>
      type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<union>
      (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values)"
    proof
      fix x
      assume "x \<in> {(type (id_to_list name), type (id_to_list name))} \<union>
        (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values \<union>
        (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
      then show "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values) \<union>
        (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<union>
        type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` EnumValue (tmod_enum name values) \<times> type ` id_to_list ` Enum (tmod_enum name values)"
      proof (elim UnE)
        assume "x \<in> {(type (id_to_list name), type (id_to_list name))}"
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      next
        assume "x \<in> (\<lambda>x. (type x, type x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        then have "x \<in> (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
        proof (elim imageE)
          fix a b c
          assume c_def: "c \<in> values"
          assume b_def: "b = [c]"
          assume "a = id_to_list name @ b"
          then have a_def: "a = id_to_list name @ [c]"
            by (simp add: b_def)
          assume "x = (type a, type a)"
          then have x_def: "x = (type (id_to_list name @ [c]), type (id_to_list name @ [c]))"
            by (simp add: a_def)
          then show ?thesis
            by (simp add: c_def image_iff)
        qed
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      next
        assume "x \<in> (\<lambda>x. (type x, type (id_to_list name))) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        then have "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values \<times> type ` id_to_list ` {name}"
        proof (elim imageE)
          fix a b c
          assume c_def: "c \<in> values"
          assume b_def: "b = [c]"
          assume "a = id_to_list name @ b"
          then have a_def: "a = id_to_list name @ [c]"
            by (simp add: b_def)
          assume "x = (type a, type (id_to_list name))"
          then have x_def: "x = (type (id_to_list name @ [c]), type (id_to_list name))"
            by (simp add: a_def)
          then show ?thesis
            by (simp add: c_def image_iff)
        qed
        then show ?thesis
          unfolding tmod_enum_def
          by simp
      qed
    qed
  qed
  have abs_proj: "type ` id_to_list ` Enum (tmod_enum name values) = {type (id_to_list name)}"
    unfolding tmod_enum_def
    by fastforce
  show "tmod_enum_to_tg_enum_as_node_types (tmod_enum name values) = tg_enum_as_node_types name values"
    unfolding tmod_enum_to_tg_enum_as_node_types_def tg_enum_as_node_types_def
    using nt_proj inh_proj abs_proj
    by simp
qed

lemma tmod_enum_to_tg_enum_as_node_types_func:
  shows "tg_combine_mapping_function (tmod_enum_to_tg_enum_as_node_types) (tmod_enum name values) (tg_enum_as_node_types name values)"
proof (intro tg_combine_mapping_function.intro)
  show "tmod_enum_to_tg_enum_as_node_types (tmod_enum name values) = tg_enum_as_node_types name values"
    by (fact tmod_enum_to_tg_enum_as_node_types_proj)
next
  fix TmodX
  show "NT (tmod_enum_to_tg_enum_as_node_types (tmod_enum name values)) \<subseteq> NT (tmod_enum_to_tg_enum_as_node_types (tmod_combine (tmod_enum name values) TmodX))"
  proof
    fix x
    assume "x \<in> NT (tmod_enum_to_tg_enum_as_node_types (tmod_enum name values))"
    then have "x \<in> type ` id_to_list ` {name} \<union> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
      unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def
      by simp
    then show "x \<in> NT (tmod_enum_to_tg_enum_as_node_types (tmod_combine (tmod_enum name values) TmodX))"
    proof (elim UnE)
      assume "x \<in> type ` id_to_list ` {name}"
      then show ?thesis
        unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tmod_combine_def
        by simp
    next
      assume "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
      then show ?thesis
        unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tmod_combine_def
        by (simp add: image_Un)
    qed
  qed
next
  fix TmodX
  show "inh (tmod_enum_to_tg_enum_as_node_types (tmod_enum name values)) \<subseteq> inh (tmod_enum_to_tg_enum_as_node_types (tmod_combine (tmod_enum name values) TmodX))"
  proof
    fix x
    assume "x \<in> inh (tmod_enum_to_tg_enum_as_node_types (tmod_enum name values))"
    then have "x \<in> type ` id_to_list ` {name} \<times> type ` id_to_list ` {name} \<union>
      (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values \<union>
      type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values \<times> type ` id_to_list ` {name}"
      unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def
      by simp
    then show "x \<in> inh (tmod_enum_to_tg_enum_as_node_types (tmod_combine (tmod_enum name values) TmodX))"
    proof (elim UnE)
      assume "x \<in> type ` id_to_list ` {name} \<times> type ` id_to_list ` {name}"
      then show ?thesis
        unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tmod_combine_def
        by simp
    next
      assume "x \<in> (\<lambda>x. (type x, type x)) ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values"
      then show ?thesis
        unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tmod_combine_def
        by (simp add: image_Un)
    next
      assume "x \<in> type ` (\<lambda>x. id_to_list (fst x) @ [snd x]) ` Pair name ` values \<times> type ` id_to_list ` {name}"
      then show ?thesis
        unfolding tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tmod_combine_def
        by auto
    qed
  qed
qed (simp_all add: tmod_enum_to_tg_enum_as_node_types_def tmod_enum_def tg_enum_as_node_types_def tmod_combine_def)

definition tg_enum_as_node_types_to_tmod_enum :: "'t Id \<Rightarrow> ('t list) type_graph \<Rightarrow> 't type_model" where
  "tg_enum_as_node_types_to_tmod_enum name TG = \<lparr>
    Class = {},
    Enum = list_to_id ` unlabel ` {n \<in> NT TG. n = type (id_to_list name)},
    UserDataType = {},
    Field = {},
    FieldSig = (\<lambda>x. undefined),
    EnumValue = (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> NT TG. n \<noteq> type (id_to_list name)},
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tg_enum_as_node_types_to_tmod_enum_proj:
  shows "tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values) = tmod_enum name values"
proof-
  have "list_to_id ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` append (id_to_list name) ` (\<lambda>x. [x]) ` values. n = type (id_to_list name)} = {name}"
  proof
    show "list_to_id ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n = type (id_to_list name)} \<subseteq> {name}"
    proof
      fix x
      assume "x \<in> list_to_id ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n = type (id_to_list name)}"
      then have "x \<in> list_to_id ` unlabel ` {type (id_to_list name)}"
        by blast
      then show "x \<in> {name}"
        by (simp add: id_to_list_inverse)
    qed
  next
    show "{name} \<subseteq> list_to_id ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n = type (id_to_list name)}"
    proof
      fix x
      assume "x \<in> {name}"
      then have "x \<in> list_to_id ` unlabel ` {type (id_to_list name)}"
        by (simp add: id_to_list_inverse)
      then show "x \<in> list_to_id ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n = type (id_to_list name)}"
        by blast
    qed
  qed
  then have enum_proj: "list_to_id ` unlabel ` {n \<in> NT (tg_enum_as_node_types name values). n = type (id_to_list name)} = {name}"
    unfolding tg_enum_as_node_types_def
    by simp
  have enumvalue_proj: "(\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n \<noteq> type (id_to_list name)} = Pair name ` values"
  proof
    show "(\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n \<noteq> type (id_to_list name)} \<subseteq> Pair name ` values"
    proof
      fix x
      assume "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n \<noteq> type (id_to_list name)}"
      then have "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        by blast
      then have "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        by fastforce
      then have "x \<in> (\<lambda>x. (list_to_id (id_to_list name), x)) ` values"
        by fastforce
      then show "x \<in> Pair name ` values"
        by (simp add: id_to_list_inverse)
    qed
  next
    show "Pair name ` values \<subseteq> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n \<noteq> type (id_to_list name)}"
    proof
      fix x
      assume "x \<in> Pair name ` values"
      then have "x \<in> (\<lambda>x. (list_to_id (id_to_list name), x)) ` values"
        by (simp add: id_to_list_inverse)
      then have "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        by force
      then have "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values"
        by force
      then show "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> {type (id_to_list name)} \<union> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values. n \<noteq> type (id_to_list name)}"
        by blast
    qed
  qed
  then have enumvalue_proj: "(\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> NT (tg_enum_as_node_types name values). n \<noteq> type (id_to_list name)} = Pair name ` values"
    unfolding tg_enum_as_node_types_def
    by simp
  show "?thesis"
    unfolding tg_enum_as_node_types_to_tmod_enum_def tmod_enum_def
    using enum_proj enumvalue_proj
    by simp
qed

lemma tg_enum_as_node_types_to_tmod_enum_func:
  shows "tmod_combine_mapping_function (tg_enum_as_node_types_to_tmod_enum name) (tg_enum_as_node_types name values) (tmod_enum name values)"
proof (intro tmod_combine_mapping_function.intro)
  show "tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values) = tmod_enum name values"
    by (fact tg_enum_as_node_types_to_tmod_enum_proj)
next
  fix TGX
  show "Enum (tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values)) \<subseteq> Enum (tg_enum_as_node_types_to_tmod_enum name (tg_combine (tg_enum_as_node_types name values) TGX))"
  proof
    fix x
    assume "x \<in> Enum (tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values))"
    then have "x \<in> list_to_id ` unlabel ` {n \<in> NT (tg_enum_as_node_types name values). n = type (id_to_list name)}"
      unfolding tg_enum_as_node_types_to_tmod_enum_def
      by simp
    then show "x \<in> Enum (tg_enum_as_node_types_to_tmod_enum name (tg_combine (tg_enum_as_node_types name values) TGX))"
      unfolding tg_enum_as_node_types_to_tmod_enum_def tg_combine_def
      by fastforce
  qed
next
  fix TGX
  show "EnumValue (tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values)) \<subseteq> EnumValue (tg_enum_as_node_types_to_tmod_enum name (tg_combine (tg_enum_as_node_types name values) TGX))"
  proof
    fix x
    assume "x \<in> EnumValue (tg_enum_as_node_types_to_tmod_enum name (tg_enum_as_node_types name values))"
    then have "x \<in> (\<lambda>x. (list_to_id (butlast x), last x)) ` unlabel ` {n \<in> NT (tg_enum_as_node_types name values). n \<noteq> type (id_to_list name)}"
      unfolding tg_enum_as_node_types_to_tmod_enum_def
      by simp
    then show "x \<in> EnumValue (tg_enum_as_node_types_to_tmod_enum name (tg_combine (tg_enum_as_node_types name values) TGX))"
      unfolding tg_enum_as_node_types_to_tmod_enum_def tg_combine_def
      by fastforce
  qed
qed (simp_all add: tg_enum_as_node_types_to_tmod_enum_def tg_enum_as_node_types_def tmod_enum_def)

section "Encoding of a Enum as Flags in GROOVE"

definition tg_enum_as_flags :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t list) type_graph" where
  "tg_enum_as_flags name values = \<lparr>
    NT = {type (id_to_list name)},
    ET = (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values,
    inh = {(type (id_to_list name), type (id_to_list name))},
    abs = {},
    mult = (\<lambda>x. (if x \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values then (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1) else undefined)),
    contains = {}
  \<rparr>"

lemma tg_enum_as_flags_correct: "type_graph (tg_enum_as_flags name values)"
proof (intro type_graph.intro)
  fix n
  assume "n \<in> NT (tg_enum_as_flags name values)"
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    unfolding tg_enum_as_flags_def
    by (simp add: Lab\<^sub>t.rule_type_labels)
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_enum_as_flags name values)"
  then show "s \<in> NT (tg_enum_as_flags name values) \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT (tg_enum_as_flags name values)"
    unfolding tg_enum_as_flags_def
    using Lab\<^sub>f.simps
    by fastforce
next
  fix e
  assume e_in_edges: "e \<in> ET (tg_enum_as_flags name values)"
  have "multiplicity_pair (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1)"
  proof (intro multiplicity_pair.intro)
    show "multiplicity (m_in (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1))"
      by (intro multiplicity.intro) (simp_all)
    show "multiplicity (m_out (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1))"
      by (intro multiplicity.intro) (simp_all)
  qed
  then show "multiplicity_pair (mult (tg_enum_as_flags name values) e)"
    using e_in_edges
    unfolding tg_enum_as_flags_def
    by simp
next
  fix l s1 t1 s2 t2
  assume edge1: "(s1, l, t1) \<in> ET (tg_enum_as_flags name values)"
  assume edge2: "(s2, l, t2) \<in> ET (tg_enum_as_flags name values)"
  show "s1 = s2 \<and> t1 = t2"
    using edge1 edge2
    unfolding tg_enum_as_flags_def
    by fastforce
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_enum_as_flags name values)"
  then show "s = t"
    unfolding tg_enum_as_flags_def
    by fastforce
next
  show "Partial_order (inh (tg_enum_as_flags name values))"
    unfolding tg_enum_as_flags_def
    using linear_order_on_def
    by fastforce
qed (simp_all add: tg_enum_as_flags_def)

lemma tg_enum_as_flags_combine_correct:
  assumes "type_graph TG"
  assumes new_enum_type: "type (id_to_list name) \<notin> NT TG"
  shows "type_graph (tg_combine TG (tg_enum_as_flags name values))"
proof (intro tg_combine_distinct_correct)
  show "type_graph (tg_enum_as_flags name values)"
    by (fact tg_enum_as_flags_correct)
qed (simp_all add: tg_enum_as_flags_def assms)

subsection "Transformation functions"

definition tmod_enum_to_tg_enum_as_flags :: "'t type_model \<Rightarrow> ('t list) type_graph" where
  "tmod_enum_to_tg_enum_as_flags Tmod = \<lparr>
    NT = type ` id_to_list ` Enum Tmod,
    ET = type ` id_to_list ` Enum Tmod \<times> flag ` (\<lambda>x. [snd x]) ` EnumValue Tmod \<times> type ` id_to_list ` Enum Tmod,
    inh = type ` id_to_list ` Enum Tmod \<times> type ` id_to_list ` Enum Tmod,
    abs = {},
    mult = (\<lambda>x. (
      if x \<in> type ` id_to_list ` Enum Tmod \<times> flag ` (\<lambda>x. [snd x]) ` EnumValue Tmod \<times> type ` id_to_list ` Enum Tmod then
        (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1)
      else
        undefined)),
    contains = {}
  \<rparr>"

lemma tmod_enum_to_tg_enum_as_flags_proj:
  shows "tmod_enum_to_tg_enum_as_flags (tmod_enum name values) = tg_enum_as_flags name values"
proof-
  have et_proj: "type ` id_to_list ` Enum (tmod_enum name values) \<times>
    flag ` (\<lambda>x. [snd x]) ` EnumValue (tmod_enum name values) \<times>
    type ` id_to_list ` Enum (tmod_enum name values) =
    (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
  proof
    show "type ` id_to_list ` Enum (tmod_enum name values) \<times>
      flag ` (\<lambda>x. [snd x]) ` EnumValue (tmod_enum name values) \<times>
      type ` id_to_list ` Enum (tmod_enum name values) \<subseteq>
      (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
    proof
      fix x
      assume "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<times>
        flag ` (\<lambda>x. [snd x]) ` EnumValue (tmod_enum name values) \<times>
        type ` id_to_list ` Enum (tmod_enum name values)"
      then show "x \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
        unfolding tmod_enum_def
        by fastforce
    qed
  next
    show "(\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values \<subseteq>
      type ` id_to_list ` Enum (tmod_enum name values) \<times>
      flag ` (\<lambda>x. [snd x]) ` EnumValue (tmod_enum name values) \<times>
      type ` id_to_list ` Enum (tmod_enum name values)"
    proof
      fix x
      assume "x \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
      then have x_def: "x \<in> {type (id_to_list name)} \<times> flag ` (\<lambda>x. [x]) ` values \<times> {type (id_to_list name)}"
        by fastforce
      have "flag ` (\<lambda>x. [x]) ` values = flag ` (\<lambda>x. [snd x]) ` Pair name ` values"
      proof
        show "flag ` (\<lambda>x. [x]) ` values \<subseteq> flag ` (\<lambda>x. [snd x]) ` Pair name ` values"
        proof
          fix x
          assume "x \<in> flag ` (\<lambda>x. [x]) ` values"
          then show "x \<in> flag ` (\<lambda>x. [snd x]) ` Pair name ` values"
          proof (elim imageE)
            fix a b
            assume b_def: "b \<in> values"
            assume a_def: "a = [b]"
            assume "x = flag a"
            then have x_def: "x = flag ([b])"
              by (simp add: a_def)
            then show ?thesis
              by (simp add: b_def image_iff)
          qed
        qed
      next
        show "flag ` (\<lambda>x. [snd x]) ` Pair name ` values \<subseteq>
          flag ` (\<lambda>x. [x]) ` values"
        proof
          fix x
          assume "x \<in> flag ` (\<lambda>x. [snd x]) ` Pair name ` values"
          then show "x \<in> flag ` (\<lambda>x. [x]) ` values"
            by fastforce
        qed
      qed
      then have "x \<in> {type (id_to_list name)} \<times>
        flag ` (\<lambda>x. [snd x]) ` Pair name ` values \<times>
        {type (id_to_list name)}"
        using x_def
        by simp
      then show "x \<in> type ` id_to_list ` Enum (tmod_enum name values) \<times>
        flag ` (\<lambda>x. [snd x]) ` EnumValue (tmod_enum name values) \<times>
        type ` id_to_list ` Enum (tmod_enum name values)"
        unfolding tmod_enum_def
        by simp
    qed
  qed
  show ?thesis
    unfolding tmod_enum_to_tg_enum_as_flags_def tg_enum_as_flags_def
    using et_proj
    unfolding tmod_enum_def
    by simp
qed

lemma tmod_enum_to_tg_enum_as_flags_func:
  shows "tg_combine_mapping_function (tmod_enum_to_tg_enum_as_flags) (tmod_enum name values) (tg_enum_as_flags name values)"
proof (intro tg_combine_mapping_function.intro)
  show "tmod_enum_to_tg_enum_as_flags (tmod_enum name values) = tg_enum_as_flags name values"
    by (fact tmod_enum_to_tg_enum_as_flags_proj)
next
  fix TmodX
  show "ET (tmod_enum_to_tg_enum_as_flags (tmod_enum name values)) \<subseteq>
    ET (tmod_enum_to_tg_enum_as_flags (tmod_combine (tmod_enum name values) TmodX))"
  proof
    fix x
    assume "x \<in> ET (tmod_enum_to_tg_enum_as_flags (tmod_enum name values))"
    then have "x \<in> {type (id_to_list name)} \<times> flag ` (\<lambda>x. [snd x]) ` Pair name ` values \<times> {type (id_to_list name)}"
      unfolding tmod_enum_to_tg_enum_as_flags_def tmod_enum_def
      by simp
    then show "x \<in> ET (tmod_enum_to_tg_enum_as_flags (tmod_combine (tmod_enum name values) TmodX))"
      unfolding tmod_enum_to_tg_enum_as_flags_def tmod_enum_def tmod_combine_def
      by auto
  qed
next
  fix TmodX e
  assume "e \<in> ET (tmod_enum_to_tg_enum_as_flags (tmod_enum name values))"
  then have e_def: "e \<in> {type (id_to_list name)} \<times> flag ` (\<lambda>x. [snd x]) ` Pair name ` values \<times> {type (id_to_list name)}"
    unfolding tmod_enum_to_tg_enum_as_flags_def tmod_enum_def
    by simp
  then have mult_def: "mult (tmod_enum_to_tg_enum_as_flags (tmod_enum name values)) e = (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1)"
    unfolding tmod_enum_to_tg_enum_as_flags_def tmod_enum_def
    by simp
  have "mult (tmod_enum_to_tg_enum_as_flags (tmod_combine (tmod_enum name values) TmodX)) e = (\<^bold>0..\<^bold>1, \<^bold>0..\<^bold>1)"
    using e_def
    unfolding tmod_enum_to_tg_enum_as_flags_def tmod_enum_def tmod_combine_def
    by auto
  then show "mult (tmod_enum_to_tg_enum_as_flags (tmod_enum name values)) e =
    mult (tmod_enum_to_tg_enum_as_flags (tmod_combine (tmod_enum name values) TmodX)) e"
    using mult_def
    by simp
qed (simp_all add: tmod_enum_to_tg_enum_as_flags_def tmod_enum_def tg_enum_as_flags_def tmod_combine_def)

definition tg_enum_as_flags_to_tmod_enum :: "('t list) type_graph \<Rightarrow> 't type_model" where
  "tg_enum_as_flags_to_tmod_enum TG = \<lparr>
    Class = {},
    Enum = list_to_id ` unlabel ` NT TG,
    UserDataType = {},
    Field = {},
    FieldSig = (\<lambda>x. undefined),
    EnumValue = (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET TG,
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tg_enum_as_flags_to_tmod_enum_proj:
  shows "tg_enum_as_flags_to_tmod_enum (tg_enum_as_flags name values) = tmod_enum name values"
proof-
  have et_proj: "(\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET (tg_enum_as_flags name values) = Pair name ` values"
  proof
    show "(\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET (tg_enum_as_flags name values) \<subseteq> Pair name ` values"
    proof
      fix x
      assume "x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET (tg_enum_as_flags name values)"
      then have "x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) `
        (\<lambda>x. (LabDef.type (id_to_list name), x, LabDef.type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
        unfolding tg_enum_as_flags_def
        by simp
      then have "x \<in> (\<lambda>x. (name, x)) ` values"
        using id_to_list_inverse
        by fastforce
      then show "x \<in> Pair name ` values"
        by simp
    qed
  next
    show "Pair name ` values \<subseteq> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET (tg_enum_as_flags name values)"
    proof
      fix x
      assume "x \<in> Pair name ` values"
      then have "x \<in> (\<lambda>x. (name, x)) ` values"
        by simp
      then have "x \<in> (\<lambda>x. (list_to_id (id_to_list name), x)) ` values"
        using id_to_list_inverse
        by metis
      then have "x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) `
        (\<lambda>x. (LabDef.type (id_to_list name), x, LabDef.type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
        by force
      then show "x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET (tg_enum_as_flags name values)"
        unfolding tg_enum_as_flags_def
        by simp
    qed
  qed
  show "tg_enum_as_flags_to_tmod_enum (tg_enum_as_flags name values) = tmod_enum name values"
    unfolding tg_enum_as_flags_to_tmod_enum_def tmod_enum_def
    using et_proj
    unfolding tg_enum_as_flags_def
    by (simp add: id_to_list_inverse)
qed

lemma tg_enum_as_flags_to_tmod_enum_func:
  shows "tmod_combine_mapping_function (tg_enum_as_flags_to_tmod_enum) (tg_enum_as_flags name values) (tmod_enum name values)"
proof (intro tmod_combine_mapping_function.intro)
  show "tg_enum_as_flags_to_tmod_enum (tg_enum_as_flags name values) = tmod_enum name values"
    by (fact tg_enum_as_flags_to_tmod_enum_proj)
next
  fix TGX
  show "EnumValue (tg_enum_as_flags_to_tmod_enum (tg_enum_as_flags name values)) \<subseteq>
    EnumValue (tg_enum_as_flags_to_tmod_enum (tg_combine (tg_enum_as_flags name values) TGX))"
    unfolding tg_enum_as_flags_to_tmod_enum_def tg_combine_def
    by fastforce
qed (simp_all add: tg_enum_as_flags_to_tmod_enum_def tg_enum_as_flags_def tg_combine_def)

end


(*  Title:      HOL/Nitpick_Examples/Manual_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2014

Examples from the Nitpick manual.
*)

section {* Examples from the Nitpick Manual *}

(* The "expect" arguments to Nitpick in this theory and the other example
   theories are there so that the example can also serve as a regression test
   suite. *)

theory Manual_Nits
imports Real "~~/src/HOL/Library/Quotient_Product"
begin

section {* 2. First Steps *}

nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

subsection {* 2.1. Propositional Logic *}

lemma "P \<longleftrightarrow> Q"
nitpick [expect = genuine]
apply auto
nitpick [expect = genuine] 1
nitpick [expect = genuine] 2
oops

subsection {* 2.2. Type Variables *}

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [verbose, expect = genuine]
oops

subsection {* 2.3. Constants *}

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [show_consts, expect = genuine]
nitpick [dont_specialize, show_consts, expect = genuine]
oops

lemma "\<exists>!x. x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [expect = none]
nitpick [card 'a = 1-50, expect = none]
(* sledgehammer *)
by (metis the_equality)

subsection {* 2.4. Skolemization *}

lemma "\<exists>g. \<forall>x. g (f x) = x \<Longrightarrow> \<forall>y. \<exists>x. y = f x"
nitpick [expect = genuine]
oops

lemma "\<exists>x. \<forall>f. f x = x"
nitpick [expect = genuine]
oops

lemma "refl r \<Longrightarrow> sym r"
nitpick [expect = genuine]
oops

subsection {* 2.5. Natural Numbers and Integers *}

lemma "\<lbrakk>i \<le> j; n \<le> (m\<Colon>int)\<rbrakk> \<Longrightarrow> i * n + j * m \<le> i * m + j * n"
nitpick [expect = genuine]
nitpick [binary_ints, bits = 16, expect = genuine]
oops

lemma "\<forall>n. Suc n \<noteq> n \<Longrightarrow> P"
nitpick [card nat = 100, check_potential, tac_timeout = 5, expect = genuine]
oops

lemma "P Suc"
nitpick [expect = none]
oops

lemma "P (op +\<Colon>nat\<Rightarrow>nat\<Rightarrow>nat)"
nitpick [card nat = 1, expect = genuine]
nitpick [card nat = 2, expect = none]
oops

subsection {* 2.6. Inductive Datatypes *}

lemma "hd (xs @ [y, y]) = hd xs"
nitpick [expect = genuine]
nitpick [show_consts, show_types, expect = genuine]
oops

lemma "\<lbrakk>length xs = 1; length ys = 1\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [show_types, expect = genuine]
oops

subsection {* 2.7. Typedefs, Records, Rationals, and Reals *}

definition "three = {0\<Colon>nat, 1, 2}"
typedef three = three
  unfolding three_def by blast

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

lemma "\<lbrakk>A \<in> X; B \<in> X\<rbrakk> \<Longrightarrow> c \<in> X"
nitpick [show_types, expect = genuine]
oops

fun my_int_rel where
"my_int_rel (x, y) (u, v) = (x + v = u + y)"

quotient_type my_int = "nat \<times> nat" / my_int_rel
by (auto simp add: equivp_def fun_eq_iff)

definition add_raw where
"add_raw \<equiv> \<lambda>(x, y) (u, v). (x + (u\<Colon>nat), y + (v\<Colon>nat))"

quotient_definition "add\<Colon>my_int \<Rightarrow> my_int \<Rightarrow> my_int" is add_raw
unfolding add_raw_def by auto

lemma "add x y = add x x"
nitpick [show_types, expect = genuine]
oops

ML {*
fun my_int_postproc _ _ _ T (Const _ $ (Const _ $ t1 $ t2)) =
    HOLogic.mk_number T (snd (HOLogic.dest_number t1)
                         - snd (HOLogic.dest_number t2))
  | my_int_postproc _ _ _ _ t = t
*}

declaration {*
Nitpick_Model.register_term_postprocessor @{typ my_int} my_int_postproc
*}

lemma "add x y = add x x"
nitpick [show_types]
oops

record point =
  Xcoord :: int
  Ycoord :: int

lemma "Xcoord (p\<Colon>point) = Xcoord (q\<Colon>point)"
nitpick [show_types, expect = genuine]
oops

lemma "4 * x + 3 * (y\<Colon>real) \<noteq> 1 / 2"
nitpick [show_types, expect = genuine]
oops

subsection {* 2.8. Inductive and Coinductive Predicates *}

inductive even where
"even 0" |
"even n \<Longrightarrow> even (Suc (Suc n))"

lemma "\<exists>n. even n \<and> even (Suc n)"
nitpick [card nat = 50, unary_ints, verbose, expect = potential]
oops

lemma "\<exists>n \<le> 49. even n \<and> even (Suc n)"
nitpick [card nat = 50, unary_ints, expect = genuine]
oops

inductive even' where
"even' (0\<Colon>nat)" |
"even' 2" |
"\<lbrakk>even' m; even' n\<rbrakk> \<Longrightarrow> even' (m + n)"

lemma "\<exists>n \<in> {0, 2, 4, 6, 8}. \<not> even' n"
nitpick [card nat = 10, unary_ints, verbose, show_consts, expect = genuine]
oops

lemma "even' (n - 2) \<Longrightarrow> even' n"
nitpick [card nat = 10, show_consts, expect = genuine]
oops

coinductive nats where
"nats (x\<Colon>nat) \<Longrightarrow> nats x"

lemma "nats = (\<lambda>n. n \<in> {0, 1, 2, 3, 4})"
nitpick [card nat = 10, show_consts, expect = genuine]
oops

inductive odd where
"odd 1" |
"\<lbrakk>odd m; even n\<rbrakk> \<Longrightarrow> odd (m + n)"

lemma "odd n \<Longrightarrow> odd (n - 2)"
nitpick [card nat = 4, show_consts, expect = genuine]
oops

subsection {* 2.9. Coinductive Datatypes *}

codatatype 'a llist = LNil | LCons 'a "'a llist"

primcorec iterates where
"iterates f a = LCons a (iterates f (f a))"

lemma "xs \<noteq> LCons a xs"
nitpick [expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = iterates (\<lambda>b. a) b\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [verbose, expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = LCons a ys\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [bisim_depth = -1, show_types, expect = quasi_genuine]
nitpick [card = 1-5, expect = none]
sorry

subsection {* 2.10. Boxing *}

datatype tm = Var nat | Lam tm | App tm tm

primrec lift where
"lift (Var j) k = Var (if j < k then j else j + 1)" |
"lift (Lam t) k = Lam (lift t (k + 1))" |
"lift (App t u) k = App (lift t k) (lift u k)"

primrec loose where
"loose (Var j) k = (j \<ge> k)" |
"loose (Lam t) k = loose t (Suc k)" |
"loose (App t u) k = (loose t k \<or> loose u k)"

primrec subst\<^sub>1 where
"subst\<^sub>1 \<sigma> (Var j) = \<sigma> j" |
"subst\<^sub>1 \<sigma> (Lam t) =
 Lam (subst\<^sub>1 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 1) t)" |
"subst\<^sub>1 \<sigma> (App t u) = App (subst\<^sub>1 \<sigma> t) (subst\<^sub>1 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>1 \<sigma> t = t"
nitpick [verbose, expect = genuine]
nitpick [eval = "subst\<^sub>1 \<sigma> t", expect = genuine]
(* nitpick [dont_box, expect = unknown] *)
oops

primrec subst\<^sub>2 where
"subst\<^sub>2 \<sigma> (Var j) = \<sigma> j" |
"subst\<^sub>2 \<sigma> (Lam t) =
 Lam (subst\<^sub>2 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 0) t)" |
"subst\<^sub>2 \<sigma> (App t u) = App (subst\<^sub>2 \<sigma> t) (subst\<^sub>2 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>2 \<sigma> t = t"
nitpick [card = 1-5, expect = none]
sorry

subsection {* 2.11. Scope Monotonicity *}

lemma "length xs = length ys \<Longrightarrow> rev (zip xs ys) = zip xs (rev ys)"
nitpick [verbose, expect = genuine]
oops

lemma "\<exists>g. \<forall>x\<Colon>'b. g (f x) = x \<Longrightarrow> \<forall>y\<Colon>'a. \<exists>x. y = f x"
nitpick [mono, expect = none]
nitpick [expect = genuine]
oops

subsection {* 2.12. Inductive Properties *}

inductive_set reach where
"(4\<Colon>nat) \<in> reach" |
"n \<in> reach \<Longrightarrow> n < 4 \<Longrightarrow> 3 * n + 1 \<in> reach" |
"n \<in> reach \<Longrightarrow> n + 2 \<in> reach"

lemma "n \<in> reach \<Longrightarrow> 2 dvd n"
(* nitpick *)
apply (induct set: reach)
  apply auto
 nitpick [card = 1-4, bits = 1-4, expect = none]
 apply (thin_tac "n \<in> reach")
 nitpick [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<noteq> 0"
(* nitpick *)
apply (induct set: reach)
  apply auto
 nitpick [card = 1-4, bits = 1-4, expect = none]
 apply (thin_tac "n \<in> reach")
 nitpick [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<ge> 4"
by (induct set: reach) arith+

section {* 3. Case Studies *}

nitpick_params [max_potential = 0]

subsection {* 3.1. A Context-Free Grammar *}

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

theorem S\<^sub>1_sound:
"w \<in> S\<^sub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

theorem S\<^sub>2_sound:
"w \<in> S\<^sub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

theorem S\<^sub>3_sound:
"w \<in> S\<^sub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

theorem S\<^sub>4_sound:
"w \<in> S\<^sub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>4_A\<^sub>4_B\<^sub>4_sound_and_complete:
"w \<in> S\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
"w \<in> A\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] + 1"
"w \<in> B\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = b] = length [x \<leftarrow> w. x = a] + 1"
nitpick [card = 1-5, expect = none]
sorry

subsection {* 3.2. AA Trees *}

datatype 'a aa_tree = \<Lambda> | N "'a\<Colon>linorder" nat "'a aa_tree" "'a aa_tree"

primrec data where
"data \<Lambda> = undefined" |
"data (N x _ _ _) = x"

primrec dataset where
"dataset \<Lambda> = {}" |
"dataset (N x _ t u) = {x} \<union> dataset t \<union> dataset u"

primrec level where
"level \<Lambda> = 0" |
"level (N _ k _ _) = k"

primrec left where
"left \<Lambda> = \<Lambda>" |
"left (N _ _ t\<^sub>1 _) = t\<^sub>1"

primrec right where
"right \<Lambda> = \<Lambda>" |
"right (N _ _ _ t\<^sub>2) = t\<^sub>2"

fun wf where
"wf \<Lambda> = True" |
"wf (N _ k t u) =
 (if t = \<Lambda> then
    k = 1 \<and> (u = \<Lambda> \<or> (level u = 1 \<and> left u = \<Lambda> \<and> right u = \<Lambda>))
  else
    wf t \<and> wf u \<and> u \<noteq> \<Lambda> \<and> level t < k \<and> level u \<le> k \<and> level (right u) < k)"

fun skew where
"skew \<Lambda> = \<Lambda>" |
"skew (N x k t u) =
 (if t \<noteq> \<Lambda> \<and> k = level t then
    N (data t) k (left t) (N x k (right t) u)
  else
    N x k t u)"

fun split where
"split \<Lambda> = \<Lambda>" |
"split (N x k t u) =
 (if u \<noteq> \<Lambda> \<and> k = level (right u) then
    N (data u) (Suc k) (N x k t (left u)) (right u)
  else
    N x k t u)"

theorem dataset_skew_split:
"dataset (skew t) = dataset t"
"dataset (split t) = dataset t"
nitpick [card = 1-5, expect = none]
sorry

theorem wf_skew_split:
"wf t \<Longrightarrow> skew t = t"
"wf t \<Longrightarrow> split t = t"
nitpick [card = 1-5, expect = none]
sorry

primrec insort\<^sub>1 where
"insort\<^sub>1 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
"insort\<^sub>1 (N y k t u) x =
 (* (split \<circ> skew) *) (N y k (if x < y then insort\<^sub>1 t x else t)
                             (if x > y then insort\<^sub>1 u x else u))"

theorem wf_insort\<^sub>1: "wf t \<Longrightarrow> wf (insort\<^sub>1 t x)"
nitpick [expect = genuine]
oops

theorem wf_insort\<^sub>1_nat: "wf t \<Longrightarrow> wf (insort\<^sub>1 t (x\<Colon>nat))"
nitpick [eval = "insort\<^sub>1 t x", expect = genuine]
oops

primrec insort\<^sub>2 where
"insort\<^sub>2 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
"insort\<^sub>2 (N y k t u) x =
 (split \<circ> skew) (N y k (if x < y then insort\<^sub>2 t x else t)
                       (if x > y then insort\<^sub>2 u x else u))"

theorem wf_insort\<^sub>2: "wf t \<Longrightarrow> wf (insort\<^sub>2 t x)"
nitpick [card = 1-5, expect = none]
sorry

theorem dataset_insort\<^sub>2: "dataset (insort\<^sub>2 t x) = {x} \<union> dataset t"
nitpick [card = 1-5, expect = none]
sorry

end


(*  Title:      HOL/MicroJava/DFA/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section \<open>Products as Semilattices\<close>

theory Product
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a * 'b) ord" where
"le rA rB == %(a,b) (a',b'). a <=_rA a' & b <=_rB b'"

definition sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a * 'b)ebinop" where
"sup f g == %(a1,b1)(a2,b2). Err.sup Pair (a1 +_f a2) (b1 +_g b2)"

definition esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a * 'b ) esl" where
"esl == %(A,rA,fA) (B,rB,fB). (A \<times> B, le rA rB, sup fA fB)"

abbreviation
  lesubprod_sntax :: "'a * 'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'a * 'b \<Rightarrow> bool"
       ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
  where "p <=(rA,rB) q == p <=_(le rA rB) q"

lemma unfold_lesub_prod:
  "p <=(rA,rB) q == le rA rB p q"
  by (simp add: lesub_def)

lemma le_prod_Pair_conv [iff]:
  "((a1,b1) <=(rA,rB) (a2,b2)) = (a1 <=_rA a2 & b1 <=_rB b2)"
  by (simp add: lesub_def le_def)

lemma less_prod_Pair_conv:
  "((a1,b1) <_(Product.le rA rB) (a2,b2)) =
  (a1 <_rA a2 & b1 <=_rB b2 | a1 <=_rA a2 & b1 <_rB b2)"
apply (unfold lesssub_def)
apply simp
apply blast
done

lemma order_le_prod [iff]:
  "order(Product.le rA rB) = (order rA & order rB)"
apply (unfold Semilat.order_def)
apply simp
apply meson
done

lemma acc_le_prodI [intro!]:
  "\<lbrakk> acc r\<^sub>A; acc r\<^sub>B \<rbrakk> \<Longrightarrow> acc(Product.le r\<^sub>A r\<^sub>B)"
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done

lemma unfold_plussub_lift2:
  "e1 +_(lift2 f) e2 == lift2 f e1 e2"
  by (simp add: plussub_def)

lemma plus_eq_Err_conv [simp]:
  assumes "x \<in> A" and "y \<in> A"
    and "semilat(err A, Err.le r, lift2 f)"
  shows "(x +_f y = Err) = (\<not>(\<exists>z\<in>A. x <=_r z & y <=_r z))"
proof -
  have plus_le_conv2:
    "\<And>r f z. \<lbrakk> z \<in> err A; semilat (err A, r, f); OK x \<in> err A; OK y \<in> err A;
                 OK x +_f OK y <=_r z\<rbrakk> \<Longrightarrow> OK x <=_r z \<and> OK y <=_r z"
    by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x +_f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z \<in> err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def closed_def)
  apply simp
  done
qed

lemma err_semilat_Product_esl:
  "\<And>L1 L2. \<lbrakk> err_semilat L1; err_semilat L2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L1 L2)"
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done

end